Comparing model performance and predicting across CONUS
Alice Stears
2025-11-11
We’ve fit models to multiple different functional groups, and want to compare their performance across different iterations,
Dependencies
User defined parameters
print(params)## $readParams
## [1] TRUE
##
## $reRunClimDat
## [1] FALSE# set to true if want to run for a limited number of rows (i.e. for code testing)
reRunClimDat <- params$reRunClimDat
readParams <- params$readParamslibrary(tidyverse)
library(sf)
library(terra)
library(kableExtra)
library(knitr)
library(USA.state.boundaries)
library(tidyterra)
library(ggpubr)Read in data
use data from dayMet sampled on a grid across CONUS
# Load Data ---------------------------------------------------------------
# data ready for modeling (that has been scaled)
modDat_1_s <- readRDS("./models/scaledModelInputData.rds")
# get the soil raster, which we'll use for rasterizing the imagery
soilRastTemp <- readRDS("../../../Data_processed/SoilsRaster.rds") %>%
terra::unwrap()
# make a map of the predictions
test_rast <- rast("../../../Data_raw/dayMet/rawMonthlyData/orders/70e0da02b9d2d6e8faa8c97d211f3546/Daymet_Monthly_V4R1/data/daymet_v4_prcp_monttl_na_1980.tif") %>%
terra::aggregate(fact = 12, fun = "mean")
# download map info for visualization
data(state_boundaries_wgs84)
cropped_states <- suppressMessages(state_boundaries_wgs84 %>%
dplyr::filter(NAME!="Hawaii") %>%
dplyr::filter(NAME!="Alaska") %>%
dplyr::filter(NAME!="Puerto Rico") %>%
dplyr::filter(NAME!="American Samoa") %>%
dplyr::filter(NAME!="Guam") %>%
dplyr::filter(NAME!="Commonwealth of the Northern Mariana Islands") %>%
dplyr::filter(NAME!="United States Virgin Islands") %>%
sf::st_sf() %>%
sf::st_transform(sf::st_crs(test_rast)))
#sf::st_crop(sf::st_bbox(modDat_1_sf)+c(-1,-1,1,1))
## add ecoregion boundaries (for our ecoregion level model)
regions <- sf::st_read(dsn = "../../../Data_raw/Level2Ecoregions/", layer = "NA_CEC_Eco_Level2") ## Reading layer `NA_CEC_Eco_Level2' from data source
## `/Users/astears/Documents/Dropbox_static/Work/NAU_USGS_postdoc/cleanPED/PED_vegClimModels/Data_raw/Level2Ecoregions'
## using driver `ESRI Shapefile'
## Simple feature collection with 2261 features and 8 fields
## Geometry type: POLYGON
## Dimension: XY
## Bounding box: xmin: -4334052 ymin: -3313739 xmax: 3324076 ymax: 4267265
## Projected CRS: Sphere_ARC_INFO_Lambert_Azimuthal_Equal_Arearegions <- regions %>%
st_transform(crs = st_crs(test_rast)) %>%
st_make_valid()
ecoregionLU <- data.frame("NA_L1NAME" = sort(unique(regions$NA_L1NAME)),
"newRegion" = c(NA, "Forest", "dryShrubGrass",
"dryShrubGrass", "Forest", "dryShrubGrass",
"dryShrubGrass", "Forest", "Forest",
"dryShrubGrass", "Forest", "Forest",
"Forest", "Forest", "dryShrubGrass",
NA
))
goodRegions <- regions %>%
left_join(ecoregionLU)
mapRegions <- goodRegions %>%
filter(!is.na(newRegion)) %>%
group_by(newRegion) %>%
summarise(geometry = sf::st_union(geometry)) %>%
ungroup() %>%
st_simplify(dTolerance = 1000)## function to get model statements
getModelStatement <- function(coefficientTable, # name of the d.f that has model coefficients
modelName, # name of the column in the coefficient table that has the parameters of interest
responseVar # name of the response variable
) {
##
# coefficientTable <- grassShrub_totalHerb_trimAnoms
# modelName <- "coefficientValue_bestLambda"
# responseVar <- "TotalHerbaceousCover"
##
temp <- coefficientTable[,c("coefficientName", modelName)] %>%
drop_na()
rownames(temp) <- temp$coefficientName
temp[,modelName] <- round(temp[,modelName], 9)
# print out coefficients w/ coefficient names
tempNames <- paste0(
apply(temp, MARGIN = 1, FUN = function(x) {
if (x["coefficientName"] == "(Intercept)") {
paste0(x[modelName])
} else {
paste0(x[modelName], "*", x["coefficientName"])
}
}
),
collapse = " + "
)
# print the unscaled model statement
unscaledModelName <- paste0(responseVar, "~ exp(", tempNames, ") - 2")
# now add in the scale parameters
tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays_anom",
replacement = paste0("((annWetDegDays_anom - ",
round(scaleParams$annWetDegDays_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$annWetDegDays_anom_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr_anom",
replacement = paste0("((prcpTempCorr_anom - ",
round(scaleParams$prcpTempCorr_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_anom_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality_anom",
replacement = paste0("((prcp_seasonality_anom - ",
round(scaleParams$prcp_seasonality_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_seasonality_anom_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "annWatDef_anom",
replacement = paste0("((annWatDef_anom - ",
round(scaleParams$annWatDef_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$annWatDef_anom_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "isothermality_anom",
replacement = paste0("((isothermality_anom - ",
round(scaleParams$isothermality_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$isothermality_anom_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcp_anom",
replacement = paste0("((prcp_anom - ",
round(scaleParams$prcp_anom_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_anom_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcp ",
replacement = paste0("((prcp - ",
round(scaleParams$prcp_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcp\\^",
replacement = paste0("((prcp - ",
round(scaleParams$prcp_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_s$`scaled:scale`,9), ")^"))
tempNames <- str_replace_all(tempNames, pattern = "prcp:",
replacement = paste0("((prcp - ",
round(scaleParams$prcp_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr ",
replacement = paste0("((prcpTempCorr - ",
round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr\\^",
replacement = paste0("((prcpTempCorr - ",
round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ")^"))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr:",
replacement = paste0("((prcpTempCorr - ",
round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr\\)",
replacement = paste0("((prcpTempCorr - ",
round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), "))"))
tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr$",
replacement = paste0("((prcpTempCorr - ",
round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ",
round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "isothermality ",
replacement = paste0("((isothermality - ",
round(scaleParams$isothermality_s$`scaled:center`,9), ") / ",
round(scaleParams$isothermality_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "isothermality\\^",
replacement = paste0("((isothermality - ",
round(scaleParams$isothermality_s$`scaled:center`,9), ") / ",
round(scaleParams$isothermality_s$`scaled:scale`,9), ")^"))
tempNames <- str_replace_all(tempNames, pattern = "isothermality:",
replacement = paste0("((isothermality - ",
round(scaleParams$isothermality_s$`scaled:center`,9), ") / ",
round(scaleParams$isothermality_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "sand",
replacement = paste0("((sand - ",
round(scaleParams$sand_s$`scaled:center`,9), ") / ",
round(scaleParams$sand_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "coarse",
replacement = paste0("((coarse - ",
round(scaleParams$coarse_s$`scaled:center`,9), ") / ",
round(scaleParams$coarse_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "AWHC",
replacement = paste0("((AWHC - ",
round(scaleParams$AWHC_s$`scaled:center`,9), ") / ",
round(scaleParams$AWHC_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "carbon",
replacement = paste0("((carbon - ",
round(scaleParams$carbon_s$`scaled:center`,9), ") / ",
round(scaleParams$carbon_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "clay",
replacement = paste0("((clay - ",
round(scaleParams$clay_s$`scaled:center`,9), ") / ",
round(scaleParams$clay_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "annWatDef ",
replacement = paste0("((annWatDef - ",
round(scaleParams$annWatDef_s$`scaled:center`,9), ") / ",
round(scaleParams$annWatDef_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "annWatDef:",
replacement = paste0("((annWatDef - ",
round(scaleParams$annWatDef_s$`scaled:center`,9), ") / ",
round(scaleParams$annWatDef_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality ",
replacement = paste0("((prcp_seasonality - ",
round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality:",
replacement = paste0("((prcp_seasonality - ",
round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality\\^",
replacement = paste0("((prcp_seasonality - ",
round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), ")^"))
tempNames <- str_replace_all(tempNames, pattern = "tmean ",
replacement = paste0("((tmean - ",
round(scaleParams$tmean_s$`scaled:center`,9), ") / ",
round(scaleParams$tmean_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "tmean:",
replacement = paste0("((tmean - ",
round(scaleParams$tmean_s$`scaled:center`,9), ") / ",
round(scaleParams$tmean_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "tmean$",
replacement = paste0("((tmean - ",
round(scaleParams$tmean_s$`scaled:center`,9), ") / ",
round(scaleParams$tmean_s$`scaled:scale`,9), ")"))
tempNames <- str_replace_all(tempNames, pattern = "tmean\\^",
replacement = paste0("((tmean - ",
round(scaleParams$tmean_s$`scaled:center`,9), ") / ",
round(scaleParams$tmean_s$`scaled:scale`,9), ")^"))
tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays ",
replacement = paste0("((annWetDegDays - ",
round(scaleParams$annWetDegDays_s$`scaled:center`,9), ") / ",
round(scaleParams$annWetDegDays_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays:",
replacement = paste0("((annWetDegDays - ",
round(scaleParams$annWetDegDays_s$`scaled:center`,9), ") / ",
round(scaleParams$annWetDegDays_s$`scaled:scale`,9), "):"))
tempNames <- str_replace_all(tempNames, pattern = "prcp_dry ",
replacement = paste0("((prcp_dry - ",
round(scaleParams$prcp_dry_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_dry_s$`scaled:scale`,9), ") "))
tempNames <- str_replace_all(tempNames, pattern = "prcp_dry:",
replacement = paste0("((prcp_dry - ",
round(scaleParams$prcp_dry_s$`scaled:center`,9), ") / ",
round(scaleParams$prcp_dry_s$`scaled:scale`,9), "):"))
## print scaled model statement
scaledModelName <- paste0(responseVar, "~ exp(", tempNames, ") - 2")
return(list("scaledInputVars_ModelStatement" = unscaledModelName,
"unscaledInputVars_scaledModelStatement" = scaledModelName))
}
### make predictions
makePredictions <- function(predictionDF, modelObject) {
##
# predictionDF <- climDatPred
# modelObject <- bestLambdaMod_grassShrub_totalHerb
# ##
# pretend to scale the input variables so the model object can predict accurately
predictionDF <- predictionDF %>%
mutate(across(all_of(prednames), base::scale,scale = FALSE, center = FALSE))
# modelPredictions
modelPreds <- predict(object = modelObject, newdata = predictionDF, type = "response")
# add predictions back into the input data.frame
predictionDF <- predictionDF %>%
cbind(modelPreds)
# truncate all predictions to max out at 100
#predictionDF[predictionDF$modelPreds>100 & !is.na(predictionDF$modelPreds),"modelPreds"] <- 100
predictionDF[predictionDF$modelPreds < 0 & !is.na(predictionDF$modelPreds),"modelPreds"] <- 0
# print predicted data
return(predictionDF)
}Compare model performance
- read in model specifications for each model
filePath <- c("")
# read in model specifications
# # no reduction of anomalies
# grassShrub_totalHerb <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
# grassShrub_totalTree <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
# #grassShrub_shrub <- readRDS("./models/modelCoefficients_shrubGrass_ShrubCover.rds")
# #grassShrub_bareGround <- readRDS("./models/modelCoefficients_shrubGrass_BareGroundCover.rds")
# forest_totalHerb <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
# forest_totalTree <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
# #forest_shrub <- readRDS("./models/modelCoefficients_forest_ShrubCover.rds")
# #forest_bareGround <- readRDS("./models/modelCoefficients_forest_BareGroundCover.rds")
# CONUS_bareGround <- readRDS("./models/modelCoefficients_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
# CONUS_shrub <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")
# with reduction of anomalies
grassShrub_totalHerb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
grassShrub_totalTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
#grassShrub_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_ShrubCover.rds")
#grassShrub_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_BareGroundCover.rds")
forest_totalHerb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
forest_totalTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
#forest_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_ShrubCover.rds")
#forest_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_BareGroundCover.rds")
CONUS_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
CONUS_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")
CONUS_c3_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_C3GramCover_prop_removeAnomaliesFALSE.rds")
CONUS_c4_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_C4GramCover_prop_removeAnomaliesFALSE.rds")
CONUS_forb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ForbCover_prop_removeAnomaliesFALSE.rds")
CONUS_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
CONUS_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
forest_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
forest_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
grassShrub_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
grassShrub_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
# read in model metrics# read in model metrics# read in model metrics
# # no reduction of anomalies
# modMetrics_grassShrub_totalHerb <- readRDS("./models/modelMetrics_shrubGrass_TotalHerbaceousCover.rds")
# modMetrics_grassShrub_totalTree <- readRDS("./models/modelMetrics_shrubGrass_TotalTreeCover.rds")
# #modMetrics_grassShrub_shrub <- readRDS("./models/modelMetrics_shrubGrass_ShrubCover.rds")
# #modMetrics_grassShrub_bareGround <- readRDS("./models/modelMetrics_shrubGrass_BareGroundCover.rds")
# modMetrics_forest_totalHerb <- readRDS("./models/modelMetrics_forest_TotalHerbaceousCover.rds")
# modMetrics_forest_totalTree <- readRDS("./models/modelMetrics_forest_TotalTreeCover.rds")
# #modMetrics_forest_shrub <- readRDS("./models/modelMetrics_forest_ShrubCover.rds")
# #modMetrics_forest_bareGround <- readRDS("./models/modelMetrics_forest_BareGroundCover.rds")
# modMetrics_CONUS_bareGround <- readRDS("./models/modelMetrics_CONUS_BareGroundCover.rds")
# modMetrics_CONUS_shrub <- readRDS("./models/modelMetrics_CONUS_ShrubCover.rds")
# with reduction of anomalies
modMetrics_grassShrub_totalHerb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_totalTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
#modMetrics_grassShrub_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_ShrubCover.rds")
#modMetrics_grassShrub_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_BareGroundCover.rds")
modMetrics_forest_totalHerb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
modMetrics_forest_totalTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
#modMetrics_forest_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_ShrubCover.rds")
#modMetrics_forest_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_BareGroundCover.rds")
modMetrics_CONUS_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
modMetrics_CONUS_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")
modMetrics_CONUS_C3_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_C3GramCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_C4_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_C4GramCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_forb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ForbCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_forest_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_forest_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_ConifTreeCover_prop_removeAnomaliesFALSE.rds")Now, show the different model performance metrics for each group (for now, only showing models that remove anomalies whose corresponding weather variables aren’t present in the LASSO model)
# grass shrub
knitr::kable(format = "html", modMetrics_grassShrub_totalHerb_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "grass/shrub - Total Herbaceous Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.203 | 0.207 | 0.218 |
| bias: mean(obs-pred.) | 3.06e-13 | -2.32e-15 | -6.49e-10 |
| Total number of coefficients | 28 | 17 | 7 |
| Number of unique coefficients | 12 | 8 | 5 |
| Number of unique climate coefficients | 5 | 5 | 2 |
| Number of unique weather coefficients | 3 | 0 | 0 |
| Number of unique soils coefficients | 4 | 3 | 3 |
knitr::kable(format = "html", modMetrics_grassShrub_totalTree_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "grass/shrub - Total Tree Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.134 | 0.144 | 0.144 |
| bias: mean(obs-pred.) | -1.98e-11 | 5.52e-13 | 5.52e-13 |
| Total number of coefficients | 5 | 0 | 0 |
| Number of unique coefficients | 4 | 0 | 0 |
| Number of unique climate coefficients | 2 | 0 | 0 |
| Number of unique weather coefficients | 0 | 0 | 0 |
| Number of unique soils coefficients | 2 | 0 | 0 |
#forest
knitr::kable(format = "html", modMetrics_forest_totalHerb_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "forest - Total Herbaceous Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.22 | 0.238 | 0.238 |
| bias: mean(obs-pred.) | -1.02e-15 | -5.31e-11 | -5.31e-11 |
| Total number of coefficients | 18 | 0 | 0 |
| Number of unique coefficients | 12 | 0 | 0 |
| Number of unique climate coefficients | 5 | 0 | 0 |
| Number of unique weather coefficients | 2 | 0 | 0 |
| Number of unique soils coefficients | 5 | 0 | 0 |
knitr::kable(format = "html", modMetrics_forest_totalTree_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "forest - Total Tree Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.253 | 0.253 | 0.264 |
| bias: mean(obs-pred.) | -7.56e-11 | -3.98e-13 | 1.5e-15 |
| Total number of coefficients | 14 | 13 | 3 |
| Number of unique coefficients | 10 | 10 | 3 |
| Number of unique climate coefficients | 5 | 5 | 3 |
| Number of unique weather coefficients | 0 | 0 | 0 |
| Number of unique soils coefficients | 5 | 5 | 0 |
#CONUS
knitr::kable(format = "html", modMetrics_CONUS_shrub_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - shrub cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.142 | 0.156 | 0.156 |
| bias: mean(obs-pred.) | -3.01e-12 | 1.26e-12 | 1.26e-12 |
| Total number of coefficients | 15 | 0 | 0 |
| Number of unique coefficients | 11 | 0 | 0 |
| Number of unique climate coefficients | 6 | 0 | 0 |
| Number of unique weather coefficients | 2 | 0 | 0 |
| Number of unique soils coefficients | 3 | 0 | 0 |
knitr::kable(format = "html", modMetrics_CONUS_bareGround_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - bare ground"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.131 | 0.13 | 0.133 |
| bias: mean(obs-pred.) | -1.98e-16 | -3.25e-10 | -6.07e-12 |
| Total number of coefficients | 40 | 23 | 17 |
| Number of unique coefficients | 13 | 9 | 10 |
| Number of unique climate coefficients | 6 | 6 | 5 |
| Number of unique weather coefficients | 4 | 0 | 2 |
| Number of unique soils coefficients | 3 | 3 | 3 |
knitr::kable(format = "html", modMetrics_CONUS_C3_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - proportion of total herb. that is C3 "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.229 | 0.231 | 0.231 |
| bias: mean(obs-pred.) | -3.3e-11 | 9.18e-16 | -2.48e-11 |
| Total number of coefficients | 28 | 22 | 17 |
| Number of unique coefficients | 13 | 9 | 13 |
| Number of unique climate coefficients | 6 | 6 | 6 |
| Number of unique weather coefficients | 4 | 0 | 4 |
| Number of unique soils coefficients | 3 | 3 | 3 |
knitr::kable(format = "html", modMetrics_CONUS_C4_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - proportion of total herb. that is C4 "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.183 | 0.174 | 0.183 |
| bias: mean(obs-pred.) | -1.88e-13 | -4.3e-15 | -1.81e-15 |
| Total number of coefficients | 5 | 17 | 4 |
| Number of unique coefficients | 3 | 8 | 3 |
| Number of unique climate coefficients | 3 | 6 | 3 |
| Number of unique weather coefficients | 0 | 0 | 0 |
| Number of unique soils coefficients | 0 | 2 | 0 |
knitr::kable(format = "html", modMetrics_CONUS_forb_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - proportion of total herb. that is forb "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.228 | 0.23 | 0.229 |
| bias: mean(obs-pred.) | 4.11e-12 | 1.05e-12 | 3.24e-13 |
| Total number of coefficients | 66 | 27 | 40 |
| Number of unique coefficients | 13 | 9 | 13 |
| Number of unique climate coefficients | 6 | 6 | 6 |
| Number of unique weather coefficients | 4 | 0 | 4 |
| Number of unique soils coefficients | 3 | 3 | 3 |
knitr::kable(format = "html", modMetrics_CONUS_broadLeavedTree_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - proportion of total tree that is broad-leaved"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.308 | 0.3 | 0.312 |
| bias: mean(obs-pred.) | 1.17e-14 | -4.58e-12 | 1.92e-15 |
| Total number of coefficients | 9 | 15 | 8 |
| Number of unique coefficients | 6 | 9 | 6 |
| Number of unique climate coefficients | 5 | 6 | 5 |
| Number of unique weather coefficients | 0 | 0 | 0 |
| Number of unique soils coefficients | 1 | 3 | 1 |
knitr::kable(format = "html", modMetrics_CONUS_needleLeavedTree_trimAnom,
col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
caption = "CONUS - proportion of total tree that is needle-leaved"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))| best Lambda model | 1/2 se lambda model | 1 se lambda model | |
|---|---|---|---|
| RMSE | 0.272 | 0.278 | 0.293 |
| bias: mean(obs-pred.) | 2.45e-13 | 5.34e-14 | 1.22e-15 |
| Total number of coefficients | 10 | 8 | 2 |
| Number of unique coefficients | 7 | 6 | 2 |
| Number of unique climate coefficients | 5 | 5 | 2 |
| Number of unique weather coefficients | 0 | 0 | 0 |
| Number of unique soils coefficients | 2 | 1 | 0 |
First, get the contemporary climate and weather data that we’ll use for predictions
Get climate data from dayMet for wall-to-wall predictions (arbitrarily chose 2016)
climDat_temp <- readRDS("/Users/astears/Documents/Dropbox_static/Work/NAU_USGS_postdoc/PED_vegClimModels/Data_processed/EcoRegion_climSoilData.rds")
# rename
climDat <- climDat_temp %>%
filter(year == 2016) %>%
dplyr::select(tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_3yrAnom, NA_L1CODE,
NA_L1NAME, NA_L1KEY, newRegion, x, y, soilDepth:totalAvailableWaterHoldingCapacity) %>%
rename("tmin" = tmin_meanAnnAvg_CLIM,
"tmax" = tmax_meanAnnAvg_CLIM, #1
"tmean" = tmean_meanAnnAvg_CLIM,
"prcp" = prcp_meanAnnTotal_CLIM,
"t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
"t_cold" = T_coldestMonth_meanAnnAvg_CLIM,
"prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
"prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM,
"prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
"prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM, #3
"abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM,
"isothermality" = isothermality_meanAnnAvg_CLIM, #4
"annWatDef" = annWaterDeficit_meanAnnAvg_CLIM,
"annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
"VPD_mean" = annVPD_mean_meanAnnAvg_CLIM,
"VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
"VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
"VPD_max_95" = annVPD_max_95percentile_CLIM,
"annWatDef_95" = annWaterDeficit_95percentile_CLIM,
"annWetDegDays_5" = annWetDegDays_5percentile_CLIM,
"frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM,
"frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM,
"soilDepth" = soilDepth, #7
"clay" = surfaceClay_perc,
"sand" = avgSandPerc_acrossDepth, #8
"coarse" = avgCoarsePerc_acrossDepth, #9
"carbon" = avgOrganicCarbonPerc_0_3cm, #10
"AWHC" = totalAvailableWaterHoldingCapacity,
## anomaly variables
tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom, #19
t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom, #22
prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23
prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25
isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom, #28
VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom, #30
VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom, #31
VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33
annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom , #34
frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35
frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
) %>%
dplyr::select(-c(tmin_meanAnnAvg_3yr:Start_3yr))
rm(climDat_temp)
gc()## used (Mb) gc trigger (Mb) limit (Mb) max used (Mb)
## Ncells 2368628 126.5 3885738 207.6 NA 3885738 207.6
## Vcells 115977238 884.9 842591009 6428.5 65536 979200140 7470.8Get the scaling factors for the data used to fit the models (scaling is done to entire dataset, so only need to get once for all models), and apply those same scaling factors to the data we’ll predict with
# get the scaling factors
scaleParams <- modDat_1_s %>%
filter(Year == 2016) %>%
dplyr::select(tmin_s:AWHC_s) %>%
reframe(across(all_of(names(.)), attributes))
# apply the scaling factors to the contemporary climate data
namesToScale <- climDat %>%
dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>%
names()
climDat_scaled <- map(namesToScale, .f = function(x) {
x_new <- (climDat[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
return(data.frame(x_new))
}) %>%
purrr::list_cbind()
names(climDat_scaled) <- paste0(namesToScale, "_s")
climDatPred <- climDat %>%
dplyr::select(NA_L1CODE:y) %>%
cbind(climDat_scaled)
names(climDatPred)[7:56] <- str_remove(names(climDatPred)[7:56], pattern = "_s$")
rm(climDat_scaled)
gc()## used (Mb) gc trigger (Mb) limit (Mb) max used (Mb)
## Ncells 2375774 126.9 3885738 207.6 NA 3885738 207.6
## Vcells 141123312 1076.7 674072808 5142.8 65536 979200140 7470.8prednames_s <- modDat_1_s %>%
dplyr::select(tmin_s:AWHC_s) %>%
names()
prednames <- str_replace(prednames_s, pattern = "_s$", replacement = "")
climDat_long <- climDatPred %>%
rename_with(.cols = any_of(c(prednames, "tmin", "tmax")), .fn = ~paste0(.x, "_s")) %>%
pivot_longer(cols = c(tmin_s:AWHC_s), names_to = "variableName", values_to = "values") %>%
mutate(source = "climDat") %>%
dplyr::select(x, y, variableName, values, source)
modDat_long <- modDat_1_s %>%
pivot_longer(cols = c(tmin_s:AWHC_s), names_to = "variableName", values_to = "values") %>%
mutate(source = "modDat") %>%
rename(x = x, y = y) %>%
dplyr::select(x, y, variableName, values, source)
allDat_long <- climDat_long %>%
rbind(modDat_long)
ggplot(allDat_long) +
facet_wrap(~variableName, scales = "free") +
geom_density(aes(values, col = source)) +
ggtitle("A figure to double-check that the climate data used for contemporary predictions is consistent with the data used for fitting")
Download modeled climate data from a given climate model
In this iteration, using data from the “BNU-ESM” model (what I call model #1) as the cool/wet(ish) option and the “IPSL-CM5A-MR (France)” (what I call model #1) model as the hot/dry option. For both models, we use data from the end of century w/ RCP 8.5
rm(allDat_long, climDat_long)
gc()## used (Mb) gc trigger (Mb) limit (Mb) max used (Mb)
## Ncells 2643017 141.2 5241977 280 NA 5241977 280.0
## Vcells 407339009 3107.8 1297079514 9896 65536 2511826459 19163.8if (reRunClimDat) {
# MACA data from: BNU-ESM model (cool/wet-ish)
## read in tmin data
tmin_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_1a) <- terra::time(tmin_1a)
tmin_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_1b) <- terra::time(tmin_1b)
tmin_1 <- c(tmin_1a, tmin_1b)
# get points to subsample
points <- terra::crds(tmin_1)
pointsSamp <- points[sample(x = 1:nrow(points), size = 50000, replace = FALSE),] %>%
terra::vect() %>%
terra::set.crs(crs(test_rast))
# subsample tmin_1 points to a data frame
tmin_1Points <- tmin_1 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmin_1Points_temp <- tmin_1Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmin_K")
tmin_1Points_temp$Year <- as.numeric(str_split(tmin_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmin_1Points_temp$Month <- as.numeric(str_split(tmin_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# convert temp in K to degrees C
tmin_1Points_temp$tmin_C <- tmin_1Points_temp$tmin_K - 273.15
# make into a wide format again
tmin_1Points <- tmin_1Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = tmin_C,
names_glue = "tmin_C_{Month}")
## read in tmax data
tmax_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_1a) <- terra::time(tmax_1a)
tmax_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_1b) <- terra::time(tmax_1b)
tmax_1 <- c(tmax_1a, tmax_1b)
# subsample tmax points to a data frame
tmax_1Points <- tmax_1 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmax_1Points_temp <- tmax_1Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmax_K")
tmax_1Points_temp$Year <- as.numeric(str_split(tmax_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmax_1Points_temp$Month <- as.numeric(str_split(tmax_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# convert temp in K to degrees C
tmax_1Points_temp$tmax_C <- tmax_1Points_temp$tmax_K - 273.15
# make into a wide format again
tmax_1Points <- tmax_1Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = tmax_C,
names_glue = "tmax_C_{Month}")
## read in precip data
prcp_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_1a) <- terra::time(prcp_1a)
prcp_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_1b) <- terra::time(prcp_1b)
prcp_1 <- c(prcp_1a, prcp_1b)
# subsample tmax points to a data frame
prcp_1Points <- prcp_1 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
prcp_1Points_temp <- prcp_1Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "prcp_mm")
prcp_1Points_temp$Year <- as.numeric(str_split(prcp_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
prcp_1Points_temp$Month <- as.numeric(str_split(prcp_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# make into a wide format again
prcp_1Points <- prcp_1Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = prcp_mm,
names_glue = "prcp_mm_{Month}")
## add all data frames together
climDat_monthly_1 <- tmin_1Points %>%
left_join(tmax_1Points, by = c("x", "y", "Year")) %>%
left_join(prcp_1Points, by = c("x", "y", "Year"))
# MACA data from: IPSL-CM5A-MR (France) (warm/dry)
## read in tmin data
tmin_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_2a) <- terra::time(tmin_2a)
tmin_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_2b) <- terra::time(tmin_2b)
tmin_2 <- c(tmin_2a, tmin_2b)
# get points to subsample
points <- terra::crds(tmin_2)
pointsSamp <- points[sample(x = 1:nrow(points), size = 50000, replace = FALSE),] %>%
terra::vect() %>%
terra::set.crs(crs(test_rast))
# subsample tmin_2 points to a data frame
tmin_2Points <- tmin_2 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmin_2Points_temp <- tmin_2Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmin_K")
tmin_2Points_temp$Year <- as.numeric(str_split(tmin_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmin_2Points_temp$Month <- as.numeric(str_split(tmin_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# convert temp in K to degrees C
tmin_2Points_temp$tmin_C <- tmin_2Points_temp$tmin_K - 273.15
# make into a wide format again
tmin_2Points <- tmin_2Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = tmin_C,
names_glue = "tmin_C_{Month}")
## read in tmax data
tmax_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_2a) <- terra::time(tmax_2a)
tmax_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_2b) <- terra::time(tmax_2b)
tmax_2 <- c(tmax_2a, tmax_2b)
# subsample tmax points to a data frame
tmax_2Points <- tmax_2 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmax_2Points_temp <- tmax_2Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmax_K")
tmax_2Points_temp$Year <- as.numeric(str_split(tmax_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmax_2Points_temp$Month <- as.numeric(str_split(tmax_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# convert temp in K to degrees C
tmax_2Points_temp$tmax_C <- tmax_2Points_temp$tmax_K - 273.15
# make into a wide format again
tmax_2Points <- tmax_2Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = tmax_C,
names_glue = "tmax_C_{Month}")
## read in precip data
prcp_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_2a) <- terra::time(prcp_2a)
prcp_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_2b) <- terra::time(prcp_2b)
prcp_2 <- c(prcp_2a, prcp_2b)
# subsample tmax points to a data frame
prcp_2Points <- prcp_2 %>%
terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
prcp_2Points_temp <- prcp_2Points %>%
#slice_sample(n = 10) %>%
pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "prcp_mm")
prcp_2Points_temp$Year <- as.numeric(str_split(prcp_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
prcp_2Points_temp$Month <- as.numeric(str_split(prcp_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])
# make into a wide format again
prcp_2Points <- prcp_2Points_temp %>%
pivot_wider(id_cols = c(x, y, Year),
names_from = Month,
values_from = prcp_mm,
names_glue = "prcp_mm_{Month}")
## add all data frames together
climDat_monthly_2 <- tmin_2Points %>%
left_join(tmax_2Points, by = c("x", "y", "Year")) %>%
left_join(prcp_2Points, by = c("x", "y", "Year"))
# Calculate climate means and weather anomalies for the first set of climate model data
climVar_1 <- climDat_monthly_1 %>%
#slice(1:100) %>%
mutate(totalAnnPrecip = rowSums(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")]), # total annual precipitation in mm
T_warmestMonth = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12")], max), # temperature of warmest month
T_coldestMonth = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], min), # temperature of coldest month
Tmin_annAvgOfMonthly = rowSums(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")])/12,
Tmax_annAvgOfMonthly = rowSums(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12")])/12,
#meanAnnVp = rowMeans(.[28:39]), # annual mean vapor pressure
precip_wettestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
max), # precip of wettest month
precip_driestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
min), # precip of driest month
precip_Seasonality = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], # coefficient of variation (sd/mean) of precipitation
.f = function(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...)
{temp <- c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12)
sd(temp)/mean(temp)
}
),
PrecipTempCorr = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12",
"prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], #correlation of monthly temp and precip
.f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12,
prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) {
cor(y = c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12),
x = c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12))
}),
aboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
.f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12) {
temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
which(temp > 0)[1] # in degrees C
}),
lastAboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
.f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12) {
temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
temp2 <- which(temp > 0) # in degrees C
if(length(temp2)>0) {
return(max(temp2))
} else {
return(NA)
}
}),
isothermality = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12",
"tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # isothermality
.f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12,
tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12, ...) {
tmins <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
tmaxes <- c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12)
tMaxMax <- max(c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12))
tMinMin <- min(c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12))
mean(tmaxes-tmins)/(tMaxMax-tMinMin) * 100
}),
) %>%
mutate(
# calculate the duration of frost-free days (in our case here, Frost-free
# days = (doy of first day of the first month when tmin is >0) - (doy of
# last day of the lost month when tmin >0))
# first month when tmin is above freezing is "aboveFreezing_month" in the previous d.f.
# last month when tmin is above freezing is "lastAboveFreezing_month" in the previous d.f.
durationFrostFreeDays =
# DOY of last day of last frost-free month (just give the 30th, since it
# probably isn't a bit deal if we use the 30th rather than the 31st in
# months when there is a 31st)
lubridate::yday(as.Date(paste0(lastAboveFreezing_month, "/30/2024"),
format = "%m/%d/%Y")) -
# DOY of first day of first frost-free month
lubridate::yday(as.Date(paste0("0",aboveFreezing_month, "/01/2024"),
format = "%m/%d/%Y"))
)
# constants for SVP calculation
#calculate SVP according to Williams et al NatCC 2012 supplementary material - units haPa
a0<-6.107799961
a1<-0.4436518521
a2<-0.01428945805
a3<-0.0002650648471
a4<-0.000003031240396
a5<-0.00000002034080948
a6<-0.00000000006136820929
## calculating vapor pressure deficit, annual water deficit, and wet degree days (based on code from Adam Noel)
climVar2_1 <- climDat_monthly_1 %>%
#slice(23507:23509) %>%
# approximation of mean temp (just avg. of max and min, which I realize is not totally accurate)
mutate(tmean_Jan = (tmax_C_1 + tmin_C_1)/2,
tmean_Feb = (tmax_C_2 + tmin_C_2)/2,
tmean_March = (tmax_C_3 + tmin_C_3)/2,
tmean_April = (tmax_C_4 + tmin_C_4)/2,
tmean_May = (tmax_C_5 + tmin_C_5)/2,
tmean_June = (tmax_C_6 + tmin_C_6)/2,
tmean_July = (tmax_C_7 + tmin_C_7)/2,
tmean_Aug = (tmax_C_8 + tmin_C_8)/2,
tmean_Sept = (tmax_C_9 + tmin_C_9)/2,
tmean_Oct = (tmax_C_10 + tmin_C_10)/2,
tmean_Nov = (tmax_C_11 + tmin_C_11)/2,
tmean_Dec = (tmax_C_12 + tmin_C_12)/2,
) %>%
mutate(
# monthly water deficit
awd_Jan = tmean_Jan*2 - prcp_mm_1,
awd_Feb = tmean_Feb*2 - prcp_mm_2,
awd_March = tmean_March*2 - prcp_mm_3,
awd_April = tmean_April*2 - prcp_mm_4,
awd_May = tmean_May*2 - prcp_mm_5,
awd_June = tmean_June*2 - prcp_mm_6,
awd_July = tmean_July*2 - prcp_mm_7,
awd_Aug = tmean_Aug*2 - prcp_mm_8,
awd_Sept = tmean_Sept*2 - prcp_mm_9,
awd_Oct = tmean_Oct*2 - prcp_mm_10,
awd_Nov = tmean_Nov*2 - prcp_mm_11,
awd_Dec = tmean_Dec*2 - prcp_mm_12,
# monthly wet degree days
##aes
awdd_Jan = ifelse(tmean_Jan*2 < prcp_mm_1, tmean_Jan*30, NA),
awdd_Feb = ifelse(tmean_Feb*2 < prcp_mm_2, tmean_Feb*30, NA),
awdd_March = ifelse(tmean_March*2 < prcp_mm_3, tmean_March*30, NA),
awdd_April = ifelse(tmean_April*2 < prcp_mm_4, tmean_April*30, NA),
awdd_May = ifelse(tmean_May*2 < prcp_mm_5, tmean_May*30, NA),
awdd_June = ifelse(tmean_June*2 < prcp_mm_6, tmean_June*30, NA),
awdd_July = ifelse(tmean_July*2 < prcp_mm_7, tmean_July*30, NA),
awdd_Aug = ifelse(tmean_Aug*2 < prcp_mm_8, tmean_Aug*30, NA),
awdd_Sept = ifelse(tmean_Sept*2 < prcp_mm_9, tmean_Sept*30, NA),
awdd_Oct = ifelse(tmean_Oct*2 < prcp_mm_10, tmean_Oct*30, NA),
awdd_Nov = ifelse(tmean_Nov*2 < prcp_mm_11, tmean_Nov*30, NA),
awdd_Dec = ifelse(tmean_Dec*2 < prcp_mm_12, tmean_Dec*30, NA),
# units are Pascals
VPD_Jan = ((( a0+ tmean_Jan*(a1+ tmean_Jan *(a2+ tmean_Jan *(a3+ tmean_Jan *(a4 + tmean_Jan *(a5 + tmean_Jan *a6)))))))*100 - (tmean_Jan))/1000,
VPD_Feb = ((( a0+ tmean_Feb*(a1+ tmean_Feb *(a2+ tmean_Feb *(a3+ tmean_Feb *(a4 + tmean_Feb *(a5 + tmean_Feb *a6)))))))*100 - (tmean_Feb))/1000,
VPD_March = ((( a0+ tmean_March*(a1+ tmean_March *(a2+ tmean_March *(a3+ tmean_March *(a4 + tmean_March *(a5 + tmean_March *a6)))))))*100 - (tmean_March))/1000,
VPD_April = ((( a0+ tmean_April*(a1+ tmean_April *(a2+ tmean_April *(a3+ tmean_April *(a4 + tmean_April *(a5 + tmean_April *a6)))))))*100 - (tmean_April))/1000,
VPD_May = ((( a0+ tmean_May*(a1+ tmean_May *(a2+ tmean_May *(a3+ tmean_May *(a4 + tmean_May *(a5 + tmean_May *a6)))))))*100 - (tmean_May))/1000,
VPD_June = ((( a0+ tmean_June*(a1+ tmean_June *(a2+ tmean_June *(a3+ tmean_June *(a4 + tmean_June *(a5 + tmean_June *a6)))))))*100 - (tmean_June))/1000,
VPD_July = ((( a0+ tmean_July*(a1+ tmean_July *(a2+ tmean_July *(a3+ tmean_July *(a4 + tmean_July *(a5 + tmean_July *a6)))))))*100 - (tmean_July))/1000,
VPD_Aug = ((( a0+ tmean_Aug*(a1+ tmean_Aug *(a2+ tmean_Aug *(a3+ tmean_Aug *(a4 + tmean_Aug *(a5 + tmean_Aug *a6)))))))*100 - (tmean_Aug))/1000,
VPD_Sept = ((( a0+ tmean_Sept*(a1+ tmean_Sept *(a2+ tmean_Sept *(a3+ tmean_Sept *(a4 + tmean_Sept *(a5 + tmean_Sept *a6)))))))*100 - (tmean_Sept))/1000,
VPD_Oct = ((( a0+ tmean_Oct*(a1+ tmean_Oct *(a2+ tmean_Oct *(a3+ tmean_Oct *(a4 + tmean_Oct *(a5 + tmean_Oct *a6)))))))*100 - (tmean_Oct))/1000,
VPD_Nov = ((( a0+ tmean_Nov*(a1+ tmean_Nov *(a2+ tmean_Nov *(a3+ tmean_Nov *(a4 + tmean_Nov *(a5 + tmean_Nov *a6)))))))*100 - (tmean_Nov))/1000,
VPD_Dec = ((( a0+ tmean_Dec*(a1+ tmean_Dec *(a2+ tmean_Dec *(a3+ tmean_Dec *(a4 + tmean_Dec *(a5 + tmean_Dec *a6)))))))*100 - (tmean_Dec))/1000
) %>%
#calculate annual values
transmute(#keep = c("year", "Long", "Lat"),
#mutate(
# annual water deficit (mm of water over degrees celsius)(sum across all months?)
tmean = pmap_dbl(.[c("tmean_Jan", "tmean_Feb", "tmean_March", "tmean_April", "tmean_May", "tmean_June", "tmean_July", "tmean_Aug", "tmean_Sept", "tmean_Oct" ,"tmean_Nov", "tmean_Dec")],
.f = function(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec, ...) {
temp <- sum(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec)/12
return(temp)
}),
# annual water deficit (mm of water over degrees celsius)(sum across all months?)
annWaterDeficit = pmap_dbl(.[c("awd_Jan", "awd_Feb", "awd_March", "awd_April", "awd_May", "awd_June", "awd_July", "awd_Aug", "awd_Sept", "awd_Oct" ,"awd_Nov", "awd_Dec")],
.f = function(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec, ...){
temp <- c(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec)
sum(temp[temp>0])
}
),
# annual wet degree days (temp*days) (sum only positive values)
annWetDegDays = pmap_dbl(.[c("awdd_Jan", "awdd_Feb", "awdd_March", "awdd_April", "awdd_May", "awdd_June", "awdd_July", "awdd_Aug", "awdd_Sept", "awdd_Oct" ,"awdd_Nov", "awdd_Dec")],
.f = function(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec, ...)
{
temp <- c(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec)
sum(temp[temp>0], na.rm = TRUE)
}
),
# annual average vapor pressure deficit (in milibars) ()
annVPD_mean = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")],
.f = function(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec) {
mean(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec)
}),
# annual maximum vapor pressure deficit (in milibars)
annVPD_max = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], max),
# annual minimum vapor pressure deficit (in milibars)
annVPD_min = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], min)
)
# if duration of frost free days is NA, change to 0 (high elevation points where there aren't any days >0 degrees C)
climVar_1[is.na(climVar_1[,"durationFrostFreeDays"]),"durationFrostFreeDays"] <- 0
# if first month where tmin is above freezing is NA, change to 8
climVar_1[is.na(climVar_1[,"aboveFreezing_month"]), "aboveFreezing_month"] <- 8
climVar_1 <- cbind(climVar_1, climVar2_1)
rm(climVar2_1)
gc()
## calculate MAP and MAT over past years (a sliding window?)
# function
slidingMetMeans <- function(inDat, start, end) {
endActual <- end-1 # subtract one so that we're actually looking at the 30, 10, 5, etc. years previous to the "end" year
outDat <- inDat %>%
filter(Year %in% c(start:endActual)) %>%
group_by(x, y) %>%
summarize(#sweMax_meanAnnAvg = mean(swe_annAvg),
tmin_meanAnnAvg = mean(Tmin_annAvgOfMonthly),
tmax_meanAnnAvg = mean(Tmax_annAvgOfMonthly),
tmean_meanAnnAvg = mean(tmean),
#vp_meanAnnAvg = mean(vp_annAvg),
prcp_meanAnnTotal = mean(totalAnnPrecip),
T_warmestMonth_meanAnnAvg = mean(T_warmestMonth), # temperature of warmest month
T_coldestMonth_meanAnnAvg = mean(T_coldestMonth), # temperature of coldest month
precip_wettestMonth_meanAnnAvg = mean(precip_wettestMonth), # precip of wettest month
precip_driestMonth_meanAnnAvg = mean(precip_driestMonth), # precip of driest month
precip_Seasonality_meanAnnAvg = mean(precip_Seasonality),
PrecipTempCorr_meanAnnAvg = mean(PrecipTempCorr),
aboveFreezing_month_meanAnnAvg = mean(aboveFreezing_month),
isothermality_meanAnnAvg = mean(isothermality),
annWaterDeficit_meanAnnAvg = mean(annWaterDeficit),
annWetDegDays_meanAnnAvg = mean(annWetDegDays),
annVPD_mean_meanAnnAvg = mean(annVPD_mean),
annVPD_max_meanAnnAvg = mean(annVPD_max),
annVPD_min_meanAnnAvg = mean(annVPD_min),
annVPD_max_95percentile = unname(quantile(annVPD_max, probs = 0.95, na.rm = TRUE)),
annWaterDeficit_95percentile = unname(quantile(annWaterDeficit, probs = 0.95, na.rm = TRUE)),
annWetDegDays_5percentile = unname(quantile(annWetDegDays, probs = 0.05, na.rm = TRUE)),
durationFrostFreeDays_5percentile = unname(quantile(durationFrostFreeDays, probs = 0.05, na.rm = TRUE)),
durationFrostFreeDays_meanAnnAvg = unname(mean(durationFrostFreeDays))
)
return(outDat)
}
# for last 20-year window, which is fewer than the 30 we used in the model-fitting... but I'd have to download even more MACA data, which I don't want to do right now...
annMeans_30yrs <- slidingMetMeans(inDat = climVar_1,
start = as.numeric(2099-31), end = 2099)
names(annMeans_30yrs)[3:24] <- paste0(names(annMeans_30yrs)[3:24], "_CLIM")
annMeans_30yrs$End_CLIM <- 2099
# for last 3-year window
annMeans_3yrs <- slidingMetMeans(inDat = climVar_1,
start = as.numeric(2099-4), end = 2099)
names(annMeans_3yrs)[3:24] <- paste0(names(annMeans_3yrs)[3:24], "_3yr")
annMeans_3yrs$End_3yr <- 2099
## add lagged data to the main climate value data.frame
test <- climVar_1 %>%
dplyr::select(-c(tmin_C_1:prcp_mm_12)) %>%
filter(Year == 2099) %>%
#filter(year == 2020) %>%
#slice(1:100) %>%
left_join(annMeans_30yrs, by = c("Year" = "End_CLIM",
"x" = "x",
"y" = "y")) %>%
left_join(annMeans_3yrs, by = c("Year" = "End_3yr",
"x" = "x",
"y" = "y")
)
rm(annMeans_30yrs, annMeans_3yrs)
gc()
test$Start_CLIM <- 2099-31
# save intermediate data
saveRDS(test, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_BNU-ESM_rcp8_5.rds")
#test <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_BNU-ESM_rcp8_5.rds")
rm(climVar_1)
gc()
#### calculate anomalies ####
# i.e. how do the 3 yr. lagged values compare to the 20yr lagged values?
anomDat_3yr <- test %>%
transmute(
# compare 3 yr values to 20 yr values
# tmean as absolute difference
tmean_meanAnnAvg_3yrAnom = tmean_meanAnnAvg_CLIM - tmean_meanAnnAvg_3yr,
# tmin as absolute difference
tmin_meanAnnAvg_3yrAnom = tmin_meanAnnAvg_CLIM - tmin_meanAnnAvg_3yr,
# tmax as absolute difference
tmax_meanAnnAvg_3yrAnom = tmax_meanAnnAvg_CLIM - tmax_meanAnnAvg_3yr,
# vp as % difference
#vp_meanAnnAvg_3yrAnom = (vp_meanAnnAvg_CLIM - vp_meanAnnAvg_3yr)/vp_meanAnnAvg_CLIM,
# prcp as % difference
prcp_meanAnnTotal_3yrAnom = (prcp_meanAnnTotal_CLIM - prcp_meanAnnTotal_3yr)/prcp_meanAnnTotal_CLIM,
# t warmest month as absolute difference
T_warmestMonth_meanAnnAvg_3yrAnom = T_warmestMonth_meanAnnAvg_CLIM - T_warmestMonth_meanAnnAvg_3yr,
# t coldest month as absolute difference
T_coldestMonth_meanAnnAvg_3yrAnom = T_coldestMonth_meanAnnAvg_CLIM - T_coldestMonth_meanAnnAvg_3yr,
# precip wettest month as % difference
precip_wettestMonth_meanAnnAvg_3yrAnom = (precip_wettestMonth_meanAnnAvg_CLIM - precip_wettestMonth_meanAnnAvg_3yr)/precip_wettestMonth_meanAnnAvg_CLIM,
# precip driest month as % difference
precip_driestMonth_meanAnnAvg_3yrAnom = (precip_driestMonth_meanAnnAvg_CLIM - precip_driestMonth_meanAnnAvg_3yr)/precip_driestMonth_meanAnnAvg_CLIM,
# precip seasonality as % difference
precip_Seasonality_meanAnnAvg_3yrAnom = (precip_Seasonality_meanAnnAvg_CLIM - precip_Seasonality_meanAnnAvg_3yr)/precip_Seasonality_meanAnnAvg_CLIM,
# precip tempCorr as absolute difference
PrecipTempCorr_meanAnnAvg_3yrAnom = PrecipTempCorr_meanAnnAvg_CLIM - PrecipTempCorr_meanAnnAvg_3yr,
# above Freezing month as absolute difference
aboveFreezing_month_meanAnnAvg_3yrAnom = aboveFreezing_month_meanAnnAvg_CLIM - aboveFreezing_month_meanAnnAvg_3yr,
# isothermailty as % difference
isothermality_meanAnnAvg_3yrAnom = isothermality_meanAnnAvg_CLIM - isothermality_meanAnnAvg_3yr,
# annual water deficit as % difference
annWaterDeficit_meanAnnAvg_3yrAnom = ((annWaterDeficit_meanAnnAvg_CLIM+.0001) - annWaterDeficit_meanAnnAvg_3yr)/(annWaterDeficit_meanAnnAvg_CLIM+.0001),
# wet degree days as % difference
annWetDegDays_meanAnnAvg_3yrAnom = (annWetDegDays_meanAnnAvg_CLIM - annWetDegDays_meanAnnAvg_3yr)/annWetDegDays_meanAnnAvg_CLIM,
# mean VPD as absolute difference
annVPD_mean_meanAnnAvg_3yrAnom = (annVPD_mean_meanAnnAvg_CLIM - annVPD_mean_meanAnnAvg_3yr),
# min VPD as absolute difference
annVPD_min_meanAnnAvg_3yrAnom = (annVPD_min_meanAnnAvg_CLIM - annVPD_min_meanAnnAvg_3yr),
# max VPD as absolute difference
annVPD_max_meanAnnAvg_3yrAnom = (annVPD_max_meanAnnAvg_CLIM - annVPD_max_meanAnnAvg_3yr),
# 95th percentile of max VPD as absolute difference
annVPD_max_95percentile_3yrAnom = (annVPD_max_95percentile_CLIM - annVPD_max_95percentile_3yr),
# 95th percentile of annual water deficit as % difference
annWaterDeficit_95percentile_3yrAnom = ((annWaterDeficit_95percentile_CLIM + .0001) - annWaterDeficit_95percentile_3yr)/(annWaterDeficit_95percentile_CLIM + .0001),
# 5th percentile of annual wet degree days as % difference
annWetDegDays_5percentile_3yrAnom = ((annWetDegDays_5percentile_CLIM + .0001) - annWetDegDays_5percentile_3yr)/(annWetDegDays_5percentile_CLIM + .0001),
# 5th percentile of frost-free days as absolute difference
durationFrostFreeDays_5percentile_3yrAnom = (durationFrostFreeDays_5percentile_CLIM - durationFrostFreeDays_5percentile_3yr),
# mean of frost free days as absolute difference
durationFrostFreeDays_meanAnnAvg_3yrAnom = (durationFrostFreeDays_meanAnnAvg_CLIM - durationFrostFreeDays_meanAnnAvg_3yr)
)
climDat <- cbind(test,
anomDat_3yr
)
## add soils information
soilRast <- readRDS("../../../Data_processed/SoilsRaster.rds")
crs(soilRast) == crs(test_rast)
# sample soils data for veg. points ---------------------------------------
# sample raster to get values for the points in the cover dataset
soils_df <- soilRast %>%
terra::extract(y = pointsSamp #%>% dplyr::select(-x,-y)
, xy = TRUE, bind = TRUE) %>%
as.data.frame()
# ggplot() +
# geom_point(data = climDat, aes(x,y)) +
# geom_point(data = soils_df, aes(x, y))
# calculate soils variables w/ cover data ---------------------------------
soils_new <-
soils_df %>%
dplyr::mutate(
# Soil depth
soilDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" , "horizonThickness_cm_15cm" ,
"horizonThickness_cm_25cm" , "horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" ,
"horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" , "horizonThickness_cm_125cm" ,
"horizonThickness_cm_176cm")], sum, na.rm = TRUE),
#Surface clay (influences how much moisture can get into the profile)
surfaceClay_perc = clayPerc_2cm) %>%
mutate(soilDepth = replace(soilDepth, is.na(horizonThickness_cm_2cm), values = NA)) %>%
mutate(
# Sand average across depths (avg. weighted by width of layer)
avgSandPerc_acrossDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" ,
"horizonThickness_cm_15cm" , "horizonThickness_cm_25cm" ,
"horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" ,
"horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" ,
"horizonThickness_cm_125cm" , "horizonThickness_cm_176cm",
"sandPerc_2cm", "sandPerc_7cm" , "sandPerc_15cm",
"sandPerc_25cm" , "sandPerc_35cm", "sandPerc_50cm" ,
"sandPerc_70cm", "sandPerc_90cm" ,
"sandPerc_125cm", "sandPerc_176cm", "soilDepth")],
function(horizonThickness_cm_2cm , horizonThickness_cm_7cm ,
horizonThickness_cm_15cm , horizonThickness_cm_25cm ,
horizonThickness_cm_35cm , horizonThickness_cm_50cm ,
horizonThickness_cm_70cm , horizonThickness_cm_90cm ,
horizonThickness_cm_125cm , horizonThickness_cm_176cm,
sandPerc_2cm, sandPerc_7cm , sandPerc_15cm,
sandPerc_25cm , sandPerc_35cm, sandPerc_50cm ,
sandPerc_70cm, sandPerc_90cm ,
sandPerc_125cm,sandPerc_176cm, soilDepth) {
y <- sum(c(sandPerc_2cm * horizonThickness_cm_2cm/soilDepth,
sandPerc_7cm * horizonThickness_cm_7cm/soilDepth,
sandPerc_15cm * horizonThickness_cm_15cm/soilDepth,
sandPerc_25cm * horizonThickness_cm_25cm/soilDepth,
sandPerc_35cm * horizonThickness_cm_35cm/soilDepth,
sandPerc_50cm * horizonThickness_cm_50cm/soilDepth,
sandPerc_70cm * horizonThickness_cm_70cm/soilDepth,
sandPerc_90cm * horizonThickness_cm_90cm/soilDepth,
sandPerc_125cm * horizonThickness_cm_125cm/soilDepth,
sandPerc_176cm * horizonThickness_cm_176cm/soilDepth),
na.rm = TRUE)/1
# following weighted average formula here: weighted average = sum(x * weight)/sum(weights)
return(y)
}
),
# Coarse fragments average across depths (avg. weighted by width of layer)
avgCoarsePerc_acrossDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" ,
"horizonThickness_cm_15cm" , "horizonThickness_cm_25cm" ,
"horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" ,
"horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" ,
"horizonThickness_cm_125cm" , "horizonThickness_cm_176cm",
"coarsePerc_2cm", "coarsePerc_7cm" , "coarsePerc_15cm",
"coarsePerc_25cm" , "coarsePerc_35cm", "coarsePerc_50cm" ,
"coarsePerc_70cm", "coarsePerc_90cm" ,
"coarsePerc_125cm","coarsePerc_176cm", "soilDepth")],
function(horizonThickness_cm_2cm , horizonThickness_cm_7cm ,
horizonThickness_cm_15cm , horizonThickness_cm_25cm ,
horizonThickness_cm_35cm , horizonThickness_cm_50cm ,
horizonThickness_cm_70cm , horizonThickness_cm_90cm ,
horizonThickness_cm_125cm , horizonThickness_cm_176cm,
coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm,
coarsePerc_25cm , coarsePerc_35cm, coarsePerc_50cm ,
coarsePerc_70cm, coarsePerc_90cm ,
coarsePerc_125cm,coarsePerc_176cm, soilDepth) {
y <- sum(c(coarsePerc_2cm * horizonThickness_cm_2cm/soilDepth,
coarsePerc_7cm * horizonThickness_cm_7cm/soilDepth,
coarsePerc_15cm * horizonThickness_cm_15cm/soilDepth,
coarsePerc_25cm * horizonThickness_cm_25cm/soilDepth,
coarsePerc_35cm * horizonThickness_cm_35cm/soilDepth,
coarsePerc_50cm * horizonThickness_cm_50cm/soilDepth,
coarsePerc_70cm * horizonThickness_cm_70cm/soilDepth,
coarsePerc_90cm * horizonThickness_cm_90cm/soilDepth,
coarsePerc_125cm * horizonThickness_cm_125cm/soilDepth,
coarsePerc_176cm * horizonThickness_cm_176cm/soilDepth),
na.rm = TRUE)/1
# following weighted average formula here: weighted average = sum(x * weight)/sum(weights)
return(y)
}
),
# soil organic carbon in first 3 cm
avgOrganicCarbonPerc_0_3cm = organicCarbonPerc_2cm
)
# # total profile available water-holding capacity
temp <- soils_new %>%
mutate(clayPerc_2cm = clayPerc_2cm/100,
clayPerc_7cm = clayPerc_7cm/100,
clayPerc_15cm = clayPerc_15cm/100,
clayPerc_25cm = clayPerc_25cm/100,
clayPerc_35cm = clayPerc_35cm/100,
clayPerc_50cm = clayPerc_50cm/100,
clayPerc_70cm = clayPerc_70cm/100,
clayPerc_90cm = clayPerc_90cm/100,
clayPerc_125cm = clayPerc_125cm/100,
clayPerc_176cm = clayPerc_176cm/100,
sandPerc_2cm = sandPerc_2cm/100,
sandPerc_7cm = sandPerc_7cm/100,
sandPerc_15cm = sandPerc_15cm/100,
sandPerc_25cm = sandPerc_25cm/100,
sandPerc_35cm = sandPerc_35cm/100,
sandPerc_50cm = sandPerc_50cm/100,
sandPerc_70cm = sandPerc_70cm/100,
sandPerc_90cm = sandPerc_90cm/100,
sandPerc_125cm = sandPerc_125cm/100,
sandPerc_176cm = sandPerc_176cm/100,
coarsePerc_2cm = coarsePerc_2cm/100,
coarsePerc_7cm = coarsePerc_7cm/100,
coarsePerc_15cm = coarsePerc_15cm/100,
coarsePerc_25cm = coarsePerc_25cm/100,
coarsePerc_35cm = coarsePerc_35cm/100,
coarsePerc_50cm = coarsePerc_50cm/100,
coarsePerc_70cm = coarsePerc_70cm/100,
coarsePerc_90cm = coarsePerc_90cm/100,
coarsePerc_125cm = coarsePerc_125cm/100,
coarsePerc_176cm = coarsePerc_176cm/100)
#slice(1:3)
# calculate # # intermediate value 'p'
vegSoil_p <- pmap(.l = temp[,c("sandPerc_2cm", "sandPerc_7cm", "sandPerc_15cm",
"sandPerc_25cm", "sandPerc_35cm", "sandPerc_50cm",
"sandPerc_70cm", "sandPerc_90cm" ,"sandPerc_125cm",
"sandPerc_176cm",
"clayPerc_2cm", "clayPerc_7cm" , "clayPerc_15cm",
"clayPerc_25cm", "clayPerc_35cm", "clayPerc_50cm",
"clayPerc_70cm", "clayPerc_90cm" ,"clayPerc_125cm",
"clayPerc_176cm",
"coarsePerc_2cm", "coarsePerc_7cm" , "coarsePerc_15cm",
"coarsePerc_25cm", "coarsePerc_35cm", "coarsePerc_50cm",
"coarsePerc_70cm", "coarsePerc_90cm" ,"coarsePerc_125cm",
"coarsePerc_176cm")],
function (sandPerc_2cm, sandPerc_7cm, sandPerc_15cm,
sandPerc_25cm, sandPerc_35cm, sandPerc_50cm,
sandPerc_70cm, sandPerc_90cm ,sandPerc_125cm,
sandPerc_176cm,
clayPerc_2cm, clayPerc_7cm , clayPerc_15cm,
clayPerc_25cm, clayPerc_35cm, clayPerc_50cm,
clayPerc_70cm, clayPerc_90cm ,clayPerc_125cm,
clayPerc_176cm,
coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm,
coarsePerc_25cm, coarsePerc_35cm, coarsePerc_50cm,
coarsePerc_70cm, coarsePerc_90cm ,coarsePerc_125cm,
coarsePerc_176cm) {
p <- rSOILWAT2::ptf_estimate(
sand = c(sandPerc_2cm,sandPerc_7cm , sandPerc_15cm,
sandPerc_25cm , sandPerc_35cm, sandPerc_50cm ,
sandPerc_70cm, sandPerc_90cm ,
sandPerc_125cm,sandPerc_176cm),
clay = c(clayPerc_2cm,clayPerc_7cm , clayPerc_15cm,
clayPerc_25cm , clayPerc_35cm, clayPerc_50cm ,
clayPerc_70cm, clayPerc_90cm ,
clayPerc_125cm,clayPerc_176cm),
fcoarse = c(coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm,
coarsePerc_25cm , coarsePerc_35cm, coarsePerc_50cm ,
coarsePerc_70cm, coarsePerc_90cm ,
coarsePerc_125cm,coarsePerc_176cm),
swrc_name = "Campbell1974",
ptf_name = "Cosby1984"
)
}
)
# calculate intermediate value 'tmp'
# reference "temp" data frame (which has the raw soil variables), as well as vegSoil_p, a list which has matrices for p calculated above
vegSoil_tmp <- map(.x = c(1:nrow(temp)),
function (n) {
tmp <- rSOILWAT2::swrc_swp_to_vwc(
c(-1.5, -0.033), ##AES should I change this? not totally clear what these values indicate
fcoarse = unlist(as.vector(temp[n,c("coarsePerc_2cm" ,
"coarsePerc_7cm" , "coarsePerc_15cm",
"coarsePerc_25cm", "coarsePerc_35cm",
"coarsePerc_50cm", "coarsePerc_70cm",
"coarsePerc_90cm", "coarsePerc_125cm",
"coarsePerc_176cm")])),
swrc = list(name = "Campbell1974", swrcp = vegSoil_p[[n]])
)
}
)
# # calculate final value 'awc'
vegSoil_awc <- map(.x = c(1:nrow(temp)),
function (n) {
awc <- temp[n,c("horizonThickness_cm_2cm" ,
"horizonThickness_cm_7cm" , "horizonThickness_cm_15cm" ,
"horizonThickness_cm_25cm" , "horizonThickness_cm_35cm" ,
"horizonThickness_cm_50cm" , "horizonThickness_cm_70cm" ,
"horizonThickness_cm_90cm" , "horizonThickness_cm_125cm" ,
"horizonThickness_cm_176cm")] * as.vector(diff(vegSoil_tmp[[n]])
)
#AES I assume that I sum these values across the entire profile to get "total profile awc"??
totAWC <- sum(awc, na.rm = TRUE)
}
)
soils_new$totalAvailableWaterHoldingCapacity <- unlist(vegSoil_awc)
# remove unnecessary soils variables
soils_final <- soils_new %>%
dplyr::select(-c(clayPerc_2cm:organicCarbonPerc_176cm)) %>%
filter(!is.nan(x))
#
# add soils to climate data
climDat_test <-
climDat %>%
st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
soils_final_test <- soils_final %>%
st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
forecastClimSoilsDat_1 <- climDat_test %>%
st_join(st_buffer(soils_final_test, 8000))
## for the second climate model
climVar_2 <- climDat_monthly_2 %>%
#slice(1:100) %>%
mutate(totalAnnPrecip = rowSums(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")]), # total annual precipitation in mm
T_warmestMonth = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12")], max), # temperature of warmest month
T_coldestMonth = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], min), # temperature of coldest month
Tmin_annAvgOfMonthly = rowSums(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")])/12,
Tmax_annAvgOfMonthly = rowSums(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12")])/12,
#meanAnnVp = rowMeans(.[28:39]), # annual mean vapor pressure
precip_wettestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
max), # precip of wettest month
precip_driestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
min), # precip of driest month
precip_Seasonality = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], # coefficient of variation (sd/mean) of precipitation
.f = function(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...)
{temp <- c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12)
sd(temp)/mean(temp)
}
),
PrecipTempCorr = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12",
"prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], #correlation of monthly temp and precip
.f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12,
prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) {
cor(y = c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12),
x = c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12))
}),
aboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
.f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12) {
temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
which(temp > 0)[1] # in degrees C
}),
lastAboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
.f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12) {
temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
temp2 <- which(temp > 0) # in degrees C
if(length(temp2)>0) {
return(max(temp2))
} else {
return(NA)
}
}),
isothermality = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10", "tmax_C_11", "tmax_C_12",
"tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10", "tmin_C_11", "tmin_C_12")], # isothermality
.f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12,
tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12, ...) {
tmins <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12)
tmaxes <- c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12)
tMaxMax <- max(c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10, tmax_C_11, tmax_C_12))
tMinMin <- min(c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10, tmin_C_11, tmin_C_12))
mean(tmaxes-tmins)/(tMaxMax-tMinMin) * 100
}),
) %>%
mutate(
# calculate the duration of frost-free days (in our case here, Frost-free
# days = (doy of first day of the first month when tmin is >0) - (doy of
# last day of the lost month when tmin >0))
# first month when tmin is above freezing is "aboveFreezing_month" in the previous d.f.
# last month when tmin is above freezing is "lastAboveFreezing_month" in the previous d.f.
durationFrostFreeDays =
# DOY of last day of last frost-free month (just give the 30th, since it
# probably isn't a bit deal if we use the 30th rather than the 31st in
# months when there is a 31st)
lubridate::yday(as.Date(paste0(lastAboveFreezing_month, "/30/2024"),
format = "%m/%d/%Y")) -
# DOY of first day of first frost-free month
lubridate::yday(as.Date(paste0("0",aboveFreezing_month, "/01/2024"),
format = "%m/%d/%Y"))
)
climVar2_2<- climDat_monthly_2%>%
#slice(23507:23509) %>%
# approximation of mean temp (just avg. of max and min, which I realize is not totally accurate)
mutate(tmean_Jan = (tmax_C_1 + tmin_C_1)/2,
tmean_Feb = (tmax_C_2 + tmin_C_2)/2,
tmean_March = (tmax_C_3 + tmin_C_3)/2,
tmean_April = (tmax_C_4 + tmin_C_4)/2,
tmean_May = (tmax_C_5 + tmin_C_5)/2,
tmean_June = (tmax_C_6 + tmin_C_6)/2,
tmean_July = (tmax_C_7 + tmin_C_7)/2,
tmean_Aug = (tmax_C_8 + tmin_C_8)/2,
tmean_Sept = (tmax_C_9 + tmin_C_9)/2,
tmean_Oct = (tmax_C_10 + tmin_C_10)/2,
tmean_Nov = (tmax_C_11 + tmin_C_11)/2,
tmean_Dec = (tmax_C_12 + tmin_C_12)/2,
) %>%
mutate(
# monthly water deficit
awd_Jan = tmean_Jan*2 - prcp_mm_1,
awd_Feb = tmean_Feb*2 - prcp_mm_2,
awd_March = tmean_March*2 - prcp_mm_3,
awd_April = tmean_April*2 - prcp_mm_4,
awd_May = tmean_May*2 - prcp_mm_5,
awd_June = tmean_June*2 - prcp_mm_6,
awd_July = tmean_July*2 - prcp_mm_7,
awd_Aug = tmean_Aug*2 - prcp_mm_8,
awd_Sept = tmean_Sept*2 - prcp_mm_9,
awd_Oct = tmean_Oct*2 - prcp_mm_10,
awd_Nov = tmean_Nov*2 - prcp_mm_11,
awd_Dec = tmean_Dec*2 - prcp_mm_12,
# monthly wet degree days
##aes
awdd_Jan = ifelse(tmean_Jan*2 < prcp_mm_1, tmean_Jan*30, NA),
awdd_Feb = ifelse(tmean_Feb*2 < prcp_mm_2, tmean_Feb*30, NA),
awdd_March = ifelse(tmean_March*2 < prcp_mm_3, tmean_March*30, NA),
awdd_April = ifelse(tmean_April*2 < prcp_mm_4, tmean_April*30, NA),
awdd_May = ifelse(tmean_May*2 < prcp_mm_5, tmean_May*30, NA),
awdd_June = ifelse(tmean_June*2 < prcp_mm_6, tmean_June*30, NA),
awdd_July = ifelse(tmean_July*2 < prcp_mm_7, tmean_July*30, NA),
awdd_Aug = ifelse(tmean_Aug*2 < prcp_mm_8, tmean_Aug*30, NA),
awdd_Sept = ifelse(tmean_Sept*2 < prcp_mm_9, tmean_Sept*30, NA),
awdd_Oct = ifelse(tmean_Oct*2 < prcp_mm_10, tmean_Oct*30, NA),
awdd_Nov = ifelse(tmean_Nov*2 < prcp_mm_11, tmean_Nov*30, NA),
awdd_Dec = ifelse(tmean_Dec*2 < prcp_mm_12, tmean_Dec*30, NA),
# units are Pascals
VPD_Jan = ((( a0+ tmean_Jan*(a1+ tmean_Jan *(a2+ tmean_Jan *(a3+ tmean_Jan *(a4 + tmean_Jan *(a5 + tmean_Jan *a6)))))))*100 - (tmean_Jan))/1000,
VPD_Feb = ((( a0+ tmean_Feb*(a1+ tmean_Feb *(a2+ tmean_Feb *(a3+ tmean_Feb *(a4 + tmean_Feb *(a5 + tmean_Feb *a6)))))))*100 - (tmean_Feb))/1000,
VPD_March = ((( a0+ tmean_March*(a1+ tmean_March *(a2+ tmean_March *(a3+ tmean_March *(a4 + tmean_March *(a5 + tmean_March *a6)))))))*100 - (tmean_March))/1000,
VPD_April = ((( a0+ tmean_April*(a1+ tmean_April *(a2+ tmean_April *(a3+ tmean_April *(a4 + tmean_April *(a5 + tmean_April *a6)))))))*100 - (tmean_April))/1000,
VPD_May = ((( a0+ tmean_May*(a1+ tmean_May *(a2+ tmean_May *(a3+ tmean_May *(a4 + tmean_May *(a5 + tmean_May *a6)))))))*100 - (tmean_May))/1000,
VPD_June = ((( a0+ tmean_June*(a1+ tmean_June *(a2+ tmean_June *(a3+ tmean_June *(a4 + tmean_June *(a5 + tmean_June *a6)))))))*100 - (tmean_June))/1000,
VPD_July = ((( a0+ tmean_July*(a1+ tmean_July *(a2+ tmean_July *(a3+ tmean_July *(a4 + tmean_July *(a5 + tmean_July *a6)))))))*100 - (tmean_July))/1000,
VPD_Aug = ((( a0+ tmean_Aug*(a1+ tmean_Aug *(a2+ tmean_Aug *(a3+ tmean_Aug *(a4 + tmean_Aug *(a5 + tmean_Aug *a6)))))))*100 - (tmean_Aug))/1000,
VPD_Sept = ((( a0+ tmean_Sept*(a1+ tmean_Sept *(a2+ tmean_Sept *(a3+ tmean_Sept *(a4 + tmean_Sept *(a5 + tmean_Sept *a6)))))))*100 - (tmean_Sept))/1000,
VPD_Oct = ((( a0+ tmean_Oct*(a1+ tmean_Oct *(a2+ tmean_Oct *(a3+ tmean_Oct *(a4 + tmean_Oct *(a5 + tmean_Oct *a6)))))))*100 - (tmean_Oct))/1000,
VPD_Nov = ((( a0+ tmean_Nov*(a1+ tmean_Nov *(a2+ tmean_Nov *(a3+ tmean_Nov *(a4 + tmean_Nov *(a5 + tmean_Nov *a6)))))))*100 - (tmean_Nov))/1000,
VPD_Dec = ((( a0+ tmean_Dec*(a1+ tmean_Dec *(a2+ tmean_Dec *(a3+ tmean_Dec *(a4 + tmean_Dec *(a5 + tmean_Dec *a6)))))))*100 - (tmean_Dec))/1000
) %>%
#calculate annual values
transmute(#keep = c("year", "Long", "Lat"),
#mutate(
# annual water deficit (mm of water over degrees celsius)(sum across all months?)
tmean = pmap_dbl(.[c("tmean_Jan", "tmean_Feb", "tmean_March", "tmean_April", "tmean_May", "tmean_June", "tmean_July", "tmean_Aug", "tmean_Sept", "tmean_Oct" ,"tmean_Nov", "tmean_Dec")],
.f = function(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec, ...) {
temp <- sum(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec)/12
return(temp)
}),
# annual water deficit (mm of water over degrees celsius)(sum across all months?)
annWaterDeficit = pmap_dbl(.[c("awd_Jan", "awd_Feb", "awd_March", "awd_April", "awd_May", "awd_June", "awd_July", "awd_Aug", "awd_Sept", "awd_Oct" ,"awd_Nov", "awd_Dec")],
.f = function(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec, ...){
temp <- c(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec)
sum(temp[temp>0])
}
),
# annual wet degree days (temp*days) (sum only positive values)
annWetDegDays = pmap_dbl(.[c("awdd_Jan", "awdd_Feb", "awdd_March", "awdd_April", "awdd_May", "awdd_June", "awdd_July", "awdd_Aug", "awdd_Sept", "awdd_Oct" ,"awdd_Nov", "awdd_Dec")],
.f = function(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec, ...)
{
temp <- c(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec)
sum(temp[temp>0], na.rm = TRUE)
}
),
# annual average vapor pressure deficit (in milibars) ()
annVPD_mean = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")],
.f = function(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec) {
mean(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec)
}),
# annual maximum vapor pressure deficit (in milibars)
annVPD_max = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], max),
# annual minimum vapor pressure deficit (in milibars)
annVPD_min = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], min)
)
# if duration of frost free days is NA, change to 0 (high elevation points where there aren't any days >0 degrees C)
climVar_2[is.na(climVar_2[,"durationFrostFreeDays"]),"durationFrostFreeDays"] <- 0
# if first month where tmin is above freezing is NA, change to 8
climVar_2[is.na(climVar_2[,"aboveFreezing_month"]), "aboveFreezing_month"] <- 8
climVar_2 <- cbind(climVar_2, climVar2_2)
rm(climVar2_2)
gc()
## calculate MAP and MAT over past years (a sliding window?)
# for last 20-year window, which is fewer than the 30 we used in the model-fitting... but I'd have to download even more MACA data, which I don't want to do right now...
annMeans_30yrs <- slidingMetMeans(inDat = climVar_2,
start = as.numeric(2099-31), end = 2099)
names(annMeans_30yrs)[3:24] <- paste0(names(annMeans_30yrs)[3:24], "_CLIM")
annMeans_30yrs$End_CLIM <- 2099
# for last 3-year window
annMeans_3yrs <- slidingMetMeans(inDat = climVar_2,
start = as.numeric(2099-4), end = 2099)
names(annMeans_3yrs)[3:24] <- paste0(names(annMeans_3yrs)[3:24], "_3yr")
annMeans_3yrs$End_3yr <- 2099
## add lagged data to the main climate value data.frame
test <- climVar_2 %>%
dplyr::select(-c(tmin_C_1:prcp_mm_12)) %>%
filter(Year == 2099) %>%
#filter(year == 2020) %>%
#slice(1:100) %>%
left_join(annMeans_30yrs, by = c("Year" = "End_CLIM",
"x" = "x",
"y" = "y")) %>%
left_join(annMeans_3yrs, by = c("Year" = "End_3yr",
"x" = "x",
"y" = "y")
)
rm(annMeans_30yrs, annMeans_3yrs)
gc()
test$Start_CLIM <- 2099-31
# save intermediate data
saveRDS(test, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
#test <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
rm(climVar_2)
gc()
#### calculate anomalies ####
# i.e. how do the 3 yr. lagged values compare to the 20yr lagged values?
anomDat_3yr <- test %>%
transmute(
# compare 3 yr values to 20 yr values
# tmean as absolute difference
tmean_meanAnnAvg_3yrAnom = tmean_meanAnnAvg_CLIM - tmean_meanAnnAvg_3yr,
# tmin as absolute difference
tmin_meanAnnAvg_3yrAnom = tmin_meanAnnAvg_CLIM - tmin_meanAnnAvg_3yr,
# tmax as absolute difference
tmax_meanAnnAvg_3yrAnom = tmax_meanAnnAvg_CLIM - tmax_meanAnnAvg_3yr,
# vp as % difference
#vp_meanAnnAvg_3yrAnom = (vp_meanAnnAvg_CLIM - vp_meanAnnAvg_3yr)/vp_meanAnnAvg_CLIM,
# prcp as % difference
prcp_meanAnnTotal_3yrAnom = (prcp_meanAnnTotal_CLIM - prcp_meanAnnTotal_3yr)/prcp_meanAnnTotal_CLIM,
# t warmest month as absolute difference
T_warmestMonth_meanAnnAvg_3yrAnom = T_warmestMonth_meanAnnAvg_CLIM - T_warmestMonth_meanAnnAvg_3yr,
# t coldest month as absolute difference
T_coldestMonth_meanAnnAvg_3yrAnom = T_coldestMonth_meanAnnAvg_CLIM - T_coldestMonth_meanAnnAvg_3yr,
# precip wettest month as % difference
precip_wettestMonth_meanAnnAvg_3yrAnom = (precip_wettestMonth_meanAnnAvg_CLIM - precip_wettestMonth_meanAnnAvg_3yr)/precip_wettestMonth_meanAnnAvg_CLIM,
# precip driest month as % difference
precip_driestMonth_meanAnnAvg_3yrAnom = (precip_driestMonth_meanAnnAvg_CLIM - precip_driestMonth_meanAnnAvg_3yr)/precip_driestMonth_meanAnnAvg_CLIM,
# precip seasonality as % difference
precip_Seasonality_meanAnnAvg_3yrAnom = (precip_Seasonality_meanAnnAvg_CLIM - precip_Seasonality_meanAnnAvg_3yr)/precip_Seasonality_meanAnnAvg_CLIM,
# precip tempCorr as absolute difference
PrecipTempCorr_meanAnnAvg_3yrAnom = PrecipTempCorr_meanAnnAvg_CLIM - PrecipTempCorr_meanAnnAvg_3yr,
# above Freezing month as absolute difference
aboveFreezing_month_meanAnnAvg_3yrAnom = aboveFreezing_month_meanAnnAvg_CLIM - aboveFreezing_month_meanAnnAvg_3yr,
# isothermailty as % difference
isothermality_meanAnnAvg_3yrAnom = isothermality_meanAnnAvg_CLIM - isothermality_meanAnnAvg_3yr,
# annual water deficit as % difference
annWaterDeficit_meanAnnAvg_3yrAnom = ((annWaterDeficit_meanAnnAvg_CLIM+.0001) - annWaterDeficit_meanAnnAvg_3yr)/(annWaterDeficit_meanAnnAvg_CLIM+.0001),
# wet degree days as % difference
annWetDegDays_meanAnnAvg_3yrAnom = (annWetDegDays_meanAnnAvg_CLIM - annWetDegDays_meanAnnAvg_3yr)/annWetDegDays_meanAnnAvg_CLIM,
# mean VPD as absolute difference
annVPD_mean_meanAnnAvg_3yrAnom = (annVPD_mean_meanAnnAvg_CLIM - annVPD_mean_meanAnnAvg_3yr),
# min VPD as absolute difference
annVPD_min_meanAnnAvg_3yrAnom = (annVPD_min_meanAnnAvg_CLIM - annVPD_min_meanAnnAvg_3yr),
# max VPD as absolute difference
annVPD_max_meanAnnAvg_3yrAnom = (annVPD_max_meanAnnAvg_CLIM - annVPD_max_meanAnnAvg_3yr),
# 95th percentile of max VPD as absolute difference
annVPD_max_95percentile_3yrAnom = (annVPD_max_95percentile_CLIM - annVPD_max_95percentile_3yr),
# 95th percentile of annual water deficit as % difference
annWaterDeficit_95percentile_3yrAnom = ((annWaterDeficit_95percentile_CLIM + .0001) - annWaterDeficit_95percentile_3yr)/(annWaterDeficit_95percentile_CLIM + .0001),
# 5th percentile of annual wet degree days as % difference
annWetDegDays_5percentile_3yrAnom = ((annWetDegDays_5percentile_CLIM + .0001) - annWetDegDays_5percentile_3yr)/(annWetDegDays_5percentile_CLIM + .0001),
# 5th percentile of frost-free days as absolute difference
durationFrostFreeDays_5percentile_3yrAnom = (durationFrostFreeDays_5percentile_CLIM - durationFrostFreeDays_5percentile_3yr),
# mean of frost free days as absolute difference
durationFrostFreeDays_meanAnnAvg_3yrAnom = (durationFrostFreeDays_meanAnnAvg_CLIM - durationFrostFreeDays_meanAnnAvg_3yr)
)
climDat <- cbind(test,
anomDat_3yr
)
## add soils information
climDat_test <-
climDat %>%
st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
soils_final_test <- soils_final %>%
st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
forecastClimSoilsDat_2 <- climDat_test %>%
st_join(st_buffer(soils_final_test, 8000))
# prepare for use in models
## Model # 1
#forecastClimSoilsDat_1 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")
forecastClimSoilsDat_1$x <- st_coordinates(forecastClimSoilsDat_1)[,1]
forecastClimSoilsDat_1$y <- st_coordinates(forecastClimSoilsDat_1)[,2]
## add ecoregion data
forecastClimSoilsDat_1$newRegion <- NA
forecastClimSoilsDat_1[st_covered_by(forecastClimSoilsDat_1, mapRegions[mapRegions$newRegion== "Forest",], sparse = FALSE), "newRegion"] <- "Forest"
forecastClimSoilsDat_1[st_covered_by(forecastClimSoilsDat_1, mapRegions[mapRegions$newRegion== "dryShrubGrass",], sparse = FALSE), "newRegion"] <- "dryShrubGrass"
# rename
forecastClimSoilsDat_1 <- forecastClimSoilsDat_1 %>%
st_drop_geometry() %>%
dplyr::select(x, y, Year, tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_CLIM,
tmean_meanAnnAvg_3yrAnom:durationFrostFreeDays_meanAnnAvg_3yrAnom,
soilDepth:totalAvailableWaterHoldingCapacity, newRegion) %>%
rename("tmin" = tmin_meanAnnAvg_CLIM,
"tmax" = tmax_meanAnnAvg_CLIM, #1
"tmean" = tmean_meanAnnAvg_CLIM,
"prcp" = prcp_meanAnnTotal_CLIM,
"t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
"t_cold" = T_coldestMonth_meanAnnAvg_CLIM,
"prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
"prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM,
"prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
"prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM, #3
"abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM,
"isothermality" = isothermality_meanAnnAvg_CLIM, #4
"annWatDef" = annWaterDeficit_meanAnnAvg_CLIM,
"annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
"VPD_mean" = annVPD_mean_meanAnnAvg_CLIM,
"VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
"VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
"VPD_max_95" = annVPD_max_95percentile_CLIM,
"annWatDef_95" = annWaterDeficit_95percentile_CLIM,
"annWetDegDays_5" = annWetDegDays_5percentile_CLIM,
"frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM,
"frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM,
"soilDepth" = soilDepth, #7
"clay" = surfaceClay_perc,
"sand" = avgSandPerc_acrossDepth, #8
"coarse" = avgCoarsePerc_acrossDepth, #9
"carbon" = avgOrganicCarbonPerc_0_3cm, #10
"AWHC" = totalAvailableWaterHoldingCapacity,
## anomaly variables
tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom, #19
t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom, #22
prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23
prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25
isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom, #28
VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom, #30
VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom, #31
VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33
annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom , #34
frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35
frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
)
## Model # 2
# forecastClimSoilsDat_2 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
forecastClimSoilsDat_2 <- st_as_sf(forecastClimSoilsDat_2, coords )
forecastClimSoilsDat_2$x <- st_coordinates(forecastClimSoilsDat_2)[,1]
forecastClimSoilsDat_2$y <- st_coordinates(forecastClimSoilsDat_2)[,2]
# get ecoregions
forecastClimSoilsDat_2$newRegion <- NA
forecastClimSoilsDat_2[st_covered_by(forecastClimSoilsDat_2, mapRegions[mapRegions$newRegion== "Forest",], sparse = FALSE), "newRegion"] <- "Forest"
forecastClimSoilsDat_2[st_covered_by(forecastClimSoilsDat_2, mapRegions[mapRegions$newRegion== "dryShrubGrass",], sparse = FALSE), "newRegion"] <- "dryShrubGrass"
# rename
forecastClimSoilsDat_2 <- forecastClimSoilsDat_2 %>%
st_drop_geometry() %>%
dplyr::select(x, y, Year, tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_CLIM,
tmean_meanAnnAvg_3yrAnom:durationFrostFreeDays_meanAnnAvg_3yrAnom,
soilDepth:totalAvailableWaterHoldingCapacity, newRegion) %>%
rename("tmin" = tmin_meanAnnAvg_CLIM,
"tmax" = tmax_meanAnnAvg_CLIM, #1
"tmean" = tmean_meanAnnAvg_CLIM,
"prcp" = prcp_meanAnnTotal_CLIM,
"t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
"t_cold" = T_coldestMonth_meanAnnAvg_CLIM,
"prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
"prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM,
"prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
"prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM, #3
"abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM,
"isothermality" = isothermality_meanAnnAvg_CLIM, #4
"annWatDef" = annWaterDeficit_meanAnnAvg_CLIM,
"annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
"VPD_mean" = annVPD_mean_meanAnnAvg_CLIM,
"VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
"VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
"VPD_max_95" = annVPD_max_95percentile_CLIM,
"annWatDef_95" = annWaterDeficit_95percentile_CLIM,
"annWetDegDays_5" = annWetDegDays_5percentile_CLIM,
"frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM,
"frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM,
"soilDepth" = soilDepth, #7
"clay" = surfaceClay_perc,
"sand" = avgSandPerc_acrossDepth, #8
"coarse" = avgCoarsePerc_acrossDepth, #9
"carbon" = avgOrganicCarbonPerc_0_3cm, #10
"AWHC" = totalAvailableWaterHoldingCapacity,
## anomaly variables
tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom, #19
t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom, #22
prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23
prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25
isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom, #28
VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom, #30
VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom, #31
VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33
annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom , #34
frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35
frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
)
## Get the scaling factors for the data used to fit the models (scaling is done to entire dataset, so only need to get once for all models), and apply those same scaling factors to the data we'll predict with
# get the scaling factors
scaleParams <- modDat_1_s %>%
dplyr::select(tmin_s:AWHC_s) %>%
reframe(across(all_of(names(.)), attributes))
## For first climate model
# apply the scaling factors to the contemporary climate data
namesToScale_1 <- forecastClimSoilsDat_1 %>%
dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>%
names()
forecastClimSoilsDat_scaled_1 <- map(namesToScale_1, .f = function(x) {
x_new <- (forecastClimSoilsDat_1[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
return(data.frame(x_new))
}) %>%
purrr::list_cbind()
names(forecastClimSoilsDat_scaled_1) <- paste0(namesToScale_1, "_s")
forecastClimSoilsDatPred_1 <- forecastClimSoilsDat_1 %>%
dplyr::select(x:Year, newRegion) %>%
cbind(forecastClimSoilsDat_scaled_1)
names(forecastClimSoilsDatPred_1)[5:54] <- str_remove(names(forecastClimSoilsDatPred_1)[5:54], pattern = "_s$")
prednames_s <- modDat_1_s %>%
dplyr::select(tmin_s:AWHC_s) %>%
names()
prednames <- str_replace(prednames_s, pattern = "_s$", replacement = "")
## For first climate model
# apply the scaling factors to the contemporary climate data
namesToScale_2 <- forecastClimSoilsDat_2 %>%
dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>%
names()
forecastClimSoilsDat_scaled_2 <- map(namesToScale_2, .f = function(x) {
x_new <- (forecastClimSoilsDat_2[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
return(data.frame(x_new))
}) %>%
purrr::list_cbind()
names(forecastClimSoilsDat_scaled_2) <- paste0(namesToScale_2, "_s")
forecastClimSoilsDatPred_2 <- forecastClimSoilsDat_2 %>%
dplyr::select(x:Year, newRegion) %>%
cbind(forecastClimSoilsDat_scaled_2)
names(forecastClimSoilsDatPred_2)[5:54] <- str_remove(names(forecastClimSoilsDatPred_2)[5:54], pattern = "_s$")
## save the scaled data for the first climate model
saveRDS(forecastClimSoilsDatPred_1, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")
## save the scaled data for the second climate model
saveRDS(forecastClimSoilsDatPred_2, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
# save the unscaled data for the first climate model
saveRDS(forecastClimSoilsDat_1, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5_UNSCALED.rds")
# save the unscaled data for the second climate model
saveRDS(forecastClimSoilsDat_2, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5_UNSCALED.rds")
} else {
# read in scaled data
forecastClimSoilsDatPred_1 <- readRDS(file = "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")
forecastClimSoilsDatPred_2 <- readRDS(file = "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
# read in unscaled data
forecastClimSoilsDat_1 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5_UNSCALED.rds")
forecastClimSoilsDat_2 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5_UNSCALED.rds")
}Predict for ‘level 1’ of cover types
Predict for grass/shrub total herbaceous cover: 1SE lambda model
Read in the best lambda model object
# read in model objects (is the trim anomaly version)
bestLambdaMod_GS_totHerb <- readRDS("./models/betaLASSO/TotalHerbaceousCover_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")
ModelSpec_bestLambda <- getModelStatement(coefficientTable = grassShrub_totalHerb_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "TotalHerbaceousCover")This is the 1SE Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambda$scaledInputVars_ModelStatement)## [1] "TotalHerbaceousCover~ exp(-0.919224029 + 0.226424194*tmean + 0.199667543*prcp + -0.006645681*prcp_seasonality + 0.255616862*prcpTempCorr + -0.067077337*isothermality + -0.137859482*sand + -0.075215916*coarse + 0.188211132*AWHC + -0.008632610*isothermality_anom + -0.835761794*I(prcp^2) + 0.607788406*I(prcpTempCorr^2) + -0.154134489*I(isothermality^2) + -0.027736198*I(prcpTempCorr_anom^2) + 0.060212571*I(sand^2) + 0.036930730*I(coarse^2) + 0.243114077*I(carbon^2) + -0.074220406*I(AWHC^2) + 0.017154809*isothermality:isothermality_anom + 0.427892115*prcp:isothermality + 0.221794309*prcp_seasonality:isothermality + -0.022384725*prcpTempCorr:isothermality_anom + 0.508207457*prcp:prcpTempCorr + 0.413700347*tmean:prcp + 0.046455810*prcp_seasonality:prcp_seasonality_anom + 0.299827722*prcp_seasonality:prcpTempCorr + 0.018032821*prcpTempCorr:prcp_seasonality_anom + -0.340340111*tmean:prcpTempCorr + 0.089955100*sand:AWHC) - 2"This is the 1SE Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambda$unscaledInputVars_scaledModelStatement)## [1] "TotalHerbaceousCover~ exp(-0.919224029 + 0.226424194*((tmean - 10.128868063) / 4.820305195) + 0.199667543*((prcp - 613.807482136) / 502.16616755) + -0.006645681*((prcp_seasonality - 0.922874288) / 0.245115393) + 0.255616862*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.067077337*((isothermality - 38.131295504) / 5.017482043) + -0.137859482*((sand - 47.700975096) / 16.735018944) + -0.075215916*((coarse - 12.778661958) / 11.312037701) + 0.188211132*((AWHC - 13.675056673) / 5.155918864) + -0.008632610*((isothermality_anom - 0.504344509) / 1.294064496) + -0.835761794*I(((prcp - 613.807482136) / 502.16616755)^2) + 0.607788406*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.154134489*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.027736198*I(((prcpTempCorr_anom - 0.00832419) / 0.119050826)^2) + 0.060212571*I(((sand - 47.700975096) / 16.735018944)^2) + 0.036930730*I(((coarse - 12.778661958) / 11.312037701)^2) + 0.243114077*I(((carbon - 3.67729377) / 6.403824534)^2) + -0.074220406*I(((AWHC - 13.675056673) / 5.155918864)^2) + 0.017154809*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496) + 0.427892115*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + 0.221794309*((prcp_seasonality - 0.922874288) / 0.245115393):((isothermality - 38.131295504) / 5.017482043) + -0.022384725*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496) + 0.508207457*((prcp - 613.807482136) / 502.16616755):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.413700347*((tmean - 10.128868063) / 4.820305195):((prcp - 613.807482136) / 502.16616755) + 0.046455810*((prcp_seasonality - 0.922874288) / 0.245115393):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.299827722*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.018032821*((prcpTempCorr - -0.120168217) / 0.410373104):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + -0.340340111*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.089955100*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864)) - 2"Now, predict with contemporary and future climate data
# predict w/ best SE lambda model
bestLambda_GS_totHerb_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_GS_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totHerb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_GS_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totHerb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_GS_totHerb)
# predict w/ best model
plotObs_GS_totHerb <- bestLambda_GS_totHerb_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
tempExt <- crds(plotObs_GS_totHerb, na.rm = TRUE)
plotObs_GS_totHerb_2 <- plotObs_GS_totHerb %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_GS_totHerb_bestLambdaFuture1 <- bestLambda_GS_totHerb_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_GS_totHerb_bestLambdaFuture1_2 <- plotObs_GS_totHerb_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_GS_totHerb_bestLambdaFuture2 <- bestLambda_GS_totHerb_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_GS_totHerb_bestLambdaFuture2_2 <- plotObs_GS_totHerb_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_GS_totHerb <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "TotalHerbaceousCover",
fun = mean, na.rm = TRUE)
plotObservations_GS_totHerb_2 <- plotObservations_GS_totHerb %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map_bestLambda_GS_totHerb <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the
grass/shrub ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) +
ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])
map_bestLambda_GS_totHerb_future1 <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the
grass/shrub ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) +
ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])
map_bestLambda_GS_totHerb_future2 <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the
grass/shrub ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) +
ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])
map_obs_GS_totHerb <- ggplot() +
geom_spatraster(data = plotObservations_GS_totHerb) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Observations of totalHerbaceousCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) +
ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])
hist <- ggplot(bestLambda_GS_totHerb_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totHerb_predict[bestLambda_GS_totHerb_predict$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_bestlambdaFuture1 <- ggplot(bestLambda_GS_totHerb_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totHerb_predictFuture_1[bestLambda_GS_totHerb_predictFuture_1$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_bestlambdaFuture2 <- ggplot(bestLambda_GS_totHerb_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totHerb_predictFuture_2[bestLambda_GS_totHerb_predictFuture_2$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(TotalHerbaceousCover), fill = "lightgrey", col = "darkgrey") +
geom_density(data = modDat_1_s[modDat_1_s$newRegion == "dryShrubGrass",],
aes(x = TotalHerbaceousCover), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")+
xlim(c(0,1))
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_GS_totHerb_2 - plotObs_GS_totHerb_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
grass-shrub model of TotalHerbaceousCover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))+
xlim(c(-1,1))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_GS_totHerb_bestLambdaFuture1_2 - plotObs_GS_totHerb_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
xlim(c(-1,1))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_GS_totHerb_bestLambdaFuture2_2 - plotObs_GS_totHerb_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
xlim(c(-1,1))
## conglomerate figure
ggarrange(map_obs_GS_totHerb, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map_bestLambda_GS_totHerb, map_bestLambda_GS_totHerb_future1, map_bestLambda_GS_totHerb_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
### Predict for forest total herbaceous - best lambda model Read in the
objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_F_totHerb <- readRDS("./models/betaLASSO/TotalHerbaceousCover_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambda_F_totHerb <- getModelStatement(coefficientTable = forest_totalHerb_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "TotalHerbaceousCover")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambda_F_totHerb$scaledInputVars_ModelStatement)## [1] "TotalHerbaceousCover~ exp(-1.13602873 + -0.06131127*prcp + 0.06237282*prcp_dry + 0.04037369*prcpTempCorr + -0.32578840*isothermality + -0.20493917*sand + -0.03292348*coarse + 0.12309801*AWHC + -0.11108167*isothermality_anom + 0.03128713*I(isothermality^2) + 0.13053926*I(sand^2) + 0.08683120*prcp:isothermality + -0.01761919*prcp_dry:isothermality_anom + -0.13684263*isothermality_anom:tmean + 0.06391473*prcp_dry:prcp_anom + 0.20880852*sand:AWHC + 0.03492179*clay:carbon + -0.02652128*coarse:carbon + -0.05128408*sand:carbon) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambda_F_totHerb$unscaledInputVars_scaledModelStatement)## [1] "TotalHerbaceousCover~ exp(-1.13602873 + -0.06131127*((prcp - 613.807482136) / 502.16616755) + 0.06237282*((prcp_dry - 5.007463659) / 8.212611388) + 0.04037369*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.32578840*((isothermality - 38.131295504) / 5.017482043) + -0.20493917*((sand - 47.700975096) / 16.735018944) + -0.03292348*((coarse - 12.778661958) / 11.312037701) + 0.12309801*((AWHC - 13.675056673) / 5.155918864) + -0.11108167*((isothermality_anom - 0.504344509) / 1.294064496) + 0.03128713*I(((isothermality - 38.131295504) / 5.017482043)^2) + 0.13053926*I(((sand - 47.700975096) / 16.735018944)^2) + 0.08683120*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + -0.01761919*((prcp_dry - 5.007463659) / 8.212611388):((isothermality_anom - 0.504344509) / 1.294064496) + -0.13684263*((isothermality_anom - 0.504344509) / 1.294064496) :((tmean - 10.128868063) / 4.820305195) + 0.06391473*((prcp_dry - 5.007463659) / 8.212611388):((prcp_anom - 0.021823908) / 0.147734326) + 0.20880852*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + 0.03492179*((clay - 18.493644224) / 9.080523406):((carbon - 3.67729377) / 6.403824534) + -0.02652128*((coarse - 12.778661958) / 11.312037701):((carbon - 3.67729377) / 6.403824534) + -0.05128408*((sand - 47.700975096) / 16.735018944):((carbon - 3.67729377) / 6.403824534)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_F_totHerb_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_F_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totHerb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_F_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totHerb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_F_totHerb)
# predict w/ best model
plotObs <- bestLambda_F_totHerb_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_F_totHerb_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_F_totHerb_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_F_totHerb <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "TotalHerbaceousCover",
fun = mean, na.rm = TRUE)
plotObservations_F_totHerb_2 <- plotObservations_F_totHerb %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the
forest ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the
forest ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the
forest ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_F_totHerb <- ggplot() +
geom_spatraster(data = plotObservations_F_totHerb_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalHerbaceousCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(bestLambda_F_totHerb_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totHerb_predict[bestLambda_F_totHerb_predict$newRegion %in% c("westForest", "eastForest"),],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(bestLambda_F_totHerb_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totHerb_predictFuture_1[bestLambda_F_totHerb_predictFuture_1$newRegion == "Forest",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(bestLambda_F_totHerb_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totHerb_predictFuture_2[bestLambda_F_totHerb_predictFuture_2$newRegion == "Forest",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(TotalHerbaceousCover), fill = "lightgrey", col = "darkgrey") +
geom_density(data = modDat_1_s[modDat_1_s$newRegion == "Forest",],
aes(x = TotalHerbaceousCover), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_F_totHerb_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
Forest model of TotalHerbaceousCover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_F_totHerb, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of TotalHerbaceousCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
Predict for grass/shrub Total Tree cover - best lambda model
# read in model objects (is the trim anomaly version)
bestLambdaMod_GS_totTree <- readRDS("./models/betaLASSO/TotalTreeCover_shrubGrass_noTLP_FALSE_removeAnomaliesTRUE_bestLambdaGLM.rds")
ModelSpec_bestlambda_GS_totTree <- getModelStatement(coefficientTable = grassShrub_totalTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "TotalTreeCover")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestlambda_GS_totTree$scaledInputVars_ModelStatement)## [1] "TotalTreeCover~ exp(-1.96097394 + 1.29554801*prcp + -0.26462323*prcp_seasonality + -0.05824317*sand + -0.37661550*AWHC + -0.18577846*I(sand^2)) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestlambda_GS_totTree$unscaledInputVars_scaledModelStatement)## [1] "TotalTreeCover~ exp(-1.96097394 + 1.29554801*((prcp - 613.807482136) / 502.16616755) + -0.26462323*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.05824317*((sand - 47.700975096) / 16.735018944) + -0.37661550*((AWHC - 13.675056673) / 5.155918864) + -0.18577846*I(((sand - 47.700975096) / 16.735018944)^2)) - 2"Predict with model specification for grass/shrub total tree cover
# predict w/ best SE lambda model
bestLambda_GS_totTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_GS_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_GS_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_GS_totTree)
# predict w/ best model
plotObs <- bestLambda_GS_totTree_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_GS_totTree_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_GS_totTree_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_GS_totTree <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "TotalTreeCover",
fun = mean, na.rm = TRUE)
plotObservations_GS_totTree_2 <- plotObservations_GS_totTree %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
grass/shrub ecoregion
using contemporary climate data"),
subtitle = "1/2 SE Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
grass/shrub ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "1/2 SE Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
grass/shrub ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "1/2 SE Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_GS_totTree <- ggplot() +
geom_spatraster(data = plotObservations_GS_totTree_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalTreeCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(bestLambda_GS_totTree_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totTree_predict[bestLambda_GS_totTree_predict$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_bestlambdaFuture1 <- ggplot(bestLambda_GS_totTree_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totTree_predictFuture_1[bestLambda_GS_totTree_predictFuture_1$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_bestlambdaFuture2 <- ggplot(bestLambda_GS_totTree_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_GS_totTree_predictFuture_2[bestLambda_GS_totTree_predictFuture_2$newRegion == "dryShrubGrass",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")+
xlim(c(0,1))
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(TotalTreeCover), fill = "lightgrey", col = "darkgrey") +
geom_density(data = modDat_1_s[modDat_1_s$newRegion == "dryShrubGrass",],
aes(x = TotalTreeCover), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")+
xlim(c(0,1))
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_GS_totTree_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
grass-shrub model of TotalTreeCover"),
subtitle = "using predictions from the
1/2 SE Lambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))+
xlim(c(-1,1))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalTreeCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the
1/2 SE Lambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
xlim(c(-1,1))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalTreeCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the
1/2 SE Lambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
xlim(c(-1,1))
## conglomerate figure
#ggarrange(map_obs_GS_totTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of TotalTreeCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
Predict for forest total tree cover - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_F_totTree <- readRDS("./models/betaLASSO/TotalTreeCover_forest_noTLP_FALSE_removeAnomaliesTRUE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambda_F_totTree <- getModelStatement(coefficientTable = forest_totalTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "TotalTreeCover")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambda_F_totTree$scaledInputVars_ModelStatement)## [1] "TotalTreeCover~ exp(-1.04718912 + 0.23180799*tmean + 0.26619282*prcp + 0.16834074*prcp_dry + -0.11768337*isothermality + 0.02769937*carbon + 0.06042716*AWHC + -0.05442983*prcp:isothermality + 0.21149397*prcp_dry:prcpTempCorr + 0.03115144*tmean:prcp_dry + -0.28756504*tmean:prcpTempCorr + -0.06997256*AWHC:clay + -0.06115585*carbon:clay + 0.04767956*carbon:coarse + 0.08350038*clay:sand) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambda_F_totTree$unscaledInputVars_scaledModelStatement)## [1] "TotalTreeCover~ exp(-1.04718912 + 0.23180799*((tmean - 10.128868063) / 4.820305195) + 0.26619282*((prcp - 613.807482136) / 502.16616755) + 0.16834074*((prcp_dry - 5.007463659) / 8.212611388) + -0.11768337*((isothermality - 38.131295504) / 5.017482043) + 0.02769937*((carbon - 3.67729377) / 6.403824534) + 0.06042716*((AWHC - 13.675056673) / 5.155918864) + -0.05442983*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + 0.21149397*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.03115144*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) + -0.28756504*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + -0.06997256*((AWHC - 13.675056673) / 5.155918864):((clay - 18.493644224) / 9.080523406) + -0.06115585*((carbon - 3.67729377) / 6.403824534):((clay - 18.493644224) / 9.080523406) + 0.04767956*((carbon - 3.67729377) / 6.403824534):((coarse - 12.778661958) / 11.312037701) + 0.08350038*((clay - 18.493644224) / 9.080523406):((sand - 47.700975096) / 16.735018944)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_F_totTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_F_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_F_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_F_totTree)
# predict w/ best model
plotObs <- bestLambda_F_totTree_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_F_totTree_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_F_totTree_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_F_totTree <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "TotalTreeCover",
fun = mean, na.rm = TRUE)
plotObservations_F_totTree_2 <- plotObservations_F_totTree %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
forest ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
forest ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the
forest ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_F_totTree <- ggplot() +
geom_spatraster(data = plotObservations_F_totTree_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalTreeCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(bestLambda_F_totTree_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totTree_predict[bestLambda_F_totTree_predict$newRegion %in% c("westForest", "eastForest"),],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(bestLambda_F_totTree_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totTree_predictFuture_1[bestLambda_F_totTree_predictFuture_1$newRegion == "Forest",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(bestLambda_F_totTree_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
geom_density(data = bestLambda_F_totTree_predictFuture_2[bestLambda_F_totTree_predictFuture_2$newRegion == "Forest",],
aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(TotalTreeCover), fill = "lightgrey", col = "darkgrey") +
geom_density(data = modDat_1_s[modDat_1_s$newRegion == "Forest",],
aes(x = TotalTreeCover), fill = "orchid", col = "orchid", alpha = .3) +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_F_totTree_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
Forest model of TotalTreeCover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalTreeCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalTreeCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_F_totTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of TotalTreeCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
Shrub cover, CONUS-wide - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_CONUS_shrub <- readRDS("./models/betaLASSO/ShrubCover_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambda_CONUS_shrub <- getModelStatement(coefficientTable = CONUS_shrub_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "ShrubCover")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambda_CONUS_shrub$scaledInputVars_ModelStatement)## [1] "ShrubCover~ exp(-1.661164268 + 0.129505697*prcp + -0.167549718*prcp_seasonality + -0.275834281*prcpTempCorr + 0.108831411*sand + 0.002957918*coarse + -0.050089034*isothermality_anom + -0.043288814*I(sand^2) + -0.008170561*I(AWHC^2) + -0.006961275*isothermality:annWetDegDays + 0.066565499*isothermality_anom:annWetDegDays + -0.136840654*prcpTempCorr:annWetDegDays + -0.034824804*isothermality_anom:isothermality + 0.120453433*isothermality:tmean + 0.026857654*prcp:prcp_seasonality_anom + 0.078229283*prcpTempCorr:tmean) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambda_CONUS_shrub$unscaledInputVars_scaledModelStatement)## [1] "ShrubCover~ exp(-1.661164268 + 0.129505697*((prcp - 613.807482136) / 502.16616755) + -0.167549718*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.275834281*((prcpTempCorr - -0.120168217) / 0.410373104) + 0.108831411*((sand - 47.700975096) / 16.735018944) + 0.002957918*((coarse - 12.778661958) / 11.312037701) + -0.050089034*((isothermality_anom - 0.504344509) / 1.294064496) + -0.043288814*I(((sand - 47.700975096) / 16.735018944)^2) + -0.008170561*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.006961275*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays - 1764.581754742) / 1160.387887503) + 0.066565499*((isothermality_anom - 0.504344509) / 1.294064496) :((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.136840654*((prcpTempCorr - -0.120168217) / 0.410373104):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.034824804*((isothermality_anom - 0.504344509) / 1.294064496) :((isothermality - 38.131295504) / 5.017482043) + 0.120453433*((isothermality - 38.131295504) / 5.017482043):((tmean - 10.128868063) / 4.820305195) + 0.026857654*((prcp - 613.807482136) / 502.16616755):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.078229283*((prcpTempCorr - -0.120168217) / 0.410373104):((tmean - 10.128868063) / 4.820305195)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_CONUS_shrub_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_CONUS_shrub)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_shrub_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_CONUS_shrub)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_shrub_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_CONUS_shrub)
# predict w/ best model
plotObs <- bestLambda_CONUS_shrub_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_CONUS_shrub_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_CONUS_shrub_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_CONUS_shrub <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "ShrubCover",
fun = mean, na.rm = TRUE)
plotObservations_CONUS_shrub_2 <- plotObservations_CONUS_shrub %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the
CONUS ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the
CONUS ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the
CONUS ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_shrub <- ggplot() +
geom_spatraster(data = plotObservations_CONUS_shrub_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of ShrubCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(bestLambda_CONUS_shrub_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(bestLambda_CONUS_shrub_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(bestLambda_CONUS_shrub_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(ShrubCover), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_CONUS_shrub_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
CONUS model of ShrubCover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of ShrubCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of ShrubCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_shrub, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of ShrubCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
Bare Ground Cover cover, CONUS-wide - 1SE lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
oneSELambdaMod_CONUS_bareGround <- readRDS("./models/betaLASSO/BareGroundCover_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")
ModelSpec_oneSELambdaMod_CONUS_bareGround <- getModelStatement(coefficientTable = CONUS_bareGround_trimAnoms,
modelName <- "coefficientValue_1seLambda",
responseVar <- "BareGroundCover")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_oneSELambdaMod_CONUS_bareGround$scaledInputVars_ModelStatement)## [1] "BareGroundCover~ exp(-1.940092121 + 0.278982563*tmean + 0.211638828*prcpTempCorr + 0.185247506*isothermality + -1.249089156*annWetDegDays + -0.391035245*coarse + 0.089170108*AWHC + -0.080908042*isothermality_anom + 0.037020465*annWetDegDays_anom + -0.114629109*I(tmean^2) + -0.114716023*I(prcpTempCorr^2) + -0.007955779*I(isothermality_anom^2) + 0.026297723*I(sand^2) + 0.041591386*I(coarse^2) + 0.260144916*annWetDegDays:prcp + 0.177933407*prcpTempCorr:isothermality + 0.011483867*sand + -0.005898276*I(annWetDegDays_anom^2)) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_oneSELambdaMod_CONUS_bareGround$unscaledInputVars_scaledModelStatement)## [1] "BareGroundCover~ exp(-1.940092121 + 0.278982563*((tmean - 10.128868063) / 4.820305195) + 0.211638828*((prcpTempCorr - -0.120168217) / 0.410373104) + 0.185247506*((isothermality - 38.131295504) / 5.017482043) + -1.249089156*((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.391035245*((coarse - 12.778661958) / 11.312037701) + 0.089170108*((AWHC - 13.675056673) / 5.155918864) + -0.080908042*((isothermality_anom - 0.504344509) / 1.294064496) + 0.037020465*((annWetDegDays_anom - 0.01940939) / 0.210157273) + -0.114629109*I(((tmean - 10.128868063) / 4.820305195)^2) + -0.114716023*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.007955779*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + 0.026297723*I(((sand - 47.700975096) / 16.735018944)^2) + 0.041591386*I(((coarse - 12.778661958) / 11.312037701)^2) + 0.260144916*((annWetDegDays - 1764.581754742) / 1160.387887503):((prcp - 613.807482136) / 502.16616755) + 0.177933407*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + 0.011483867*((sand - 47.700975096) / 16.735018944) + -0.005898276*I(((annWetDegDays_anom - 0.01940939) / 0.210157273)^2)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_CONUS_bareGround_predict <- makePredictions(predictionDF = climDatPred,
modelObject = oneSELambdaMod_CONUS_bareGround)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_bareGround_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = oneSELambdaMod_CONUS_bareGround)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_bareGround_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = oneSELambdaMod_CONUS_bareGround)
# predict w/ best model
plotObs <- bestLambda_CONUS_bareGround_predict %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_CONUS_bareGround_predictFuture_1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_CONUS_bareGround_predictFuture_2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "modelPreds",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_CONUS_bareGround <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "BareGroundCover",
fun = mean, na.rm = TRUE)
plotObservations_CONUS_bareGround_2 <- plotObservations_CONUS_bareGround %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the
CONUS ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the
CONUS ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the
CONUS ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_bareGround <- ggplot() +
geom_spatraster(data = plotObservations_CONUS_bareGround_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of BareGroundCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(bestLambda_CONUS_bareGround_predict) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(bestLambda_CONUS_bareGround_predictFuture_1) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(bestLambda_CONUS_bareGround_predictFuture_2) +
geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(BareGroundCover), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_CONUS_bareGround_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
CONUS model of BareGroundCover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of BareGroundCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of BareGroundCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_bareGround, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of BareGroundCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
Predict for ‘level 2’ of cover types
C3 as proportion of total herbaceous, CONUS-wide - 1SE lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
oneSELambdaMod_CONUS_C3 <- readRDS("./models/betaLASSO/C3GramCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")
ModelSpec_oneSELambdaMod_CONUS_C3 <- getModelStatement(coefficientTable = CONUS_c3_trimAnoms,
modelName <- "coefficientValue_1seLambda",
responseVar <- "c3 cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_oneSELambdaMod_CONUS_C3$scaledInputVars_ModelStatement)## [1] "c3 cover percentage~ exp( 0.18542223 + -0.44696465*tmean + -0.40362010*prcpTempCorr + -0.38780455*isothermality + -0.18796883*annWetDegDays + 0.05532026*prcp_seasonality_anom + 0.11808213*prcpTempCorr_anom + -0.11221305*annWetDegDays_anom + -0.03980364*I(prcp_seasonality^2) + -0.33614836*I(isothermality^2) + -0.03789658*I(isothermality_anom^2) + -0.05062253*I(sand^2) + -0.07158871*I(AWHC^2) + 0.28768848*isothermality:annWetDegDays + -0.51370522*prcpTempCorr:isothermality + 0.12544456*sand:AWHC + 0.16612760*sand:coarse + 0.71815988*prcpTempCorr:prcp) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_oneSELambdaMod_CONUS_C3$unscaledInputVars_scaledModelStatement)## [1] "c3 cover percentage~ exp( 0.18542223 + -0.44696465*((tmean - 10.128868063) / 4.820305195) + -0.40362010*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.38780455*((isothermality - 38.131295504) / 5.017482043) + -0.18796883*((annWetDegDays - 1764.581754742) / 1160.387887503) + 0.05532026*((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.11808213*((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.11221305*((annWetDegDays_anom - 0.01940939) / 0.210157273) + -0.03980364*I(((prcp_seasonality - 0.922874288) / 0.245115393)^2) + -0.33614836*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.03789658*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + -0.05062253*I(((sand - 47.700975096) / 16.735018944)^2) + -0.07158871*I(((AWHC - 13.675056673) / 5.155918864)^2) + 0.28768848*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.51370522*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + 0.12544456*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + 0.16612760*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701) + 0.71815988*((prcpTempCorr - -0.120168217) / 0.410373104):prcp) - 2"Predict
# predict w/ best SE lambda model
bestLambda_CONUS_C3_predict <- makePredictions(predictionDF = climDatPred,
modelObject = oneSELambdaMod_CONUS_C3)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C3_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = oneSELambdaMod_CONUS_C3)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C3_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = oneSELambdaMod_CONUS_C3)C4 as proportion of total herbaceous, CONUS-wide - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
oneSELambdaMod_CONUS_C4 <- readRDS("./models/betaLASSO/C4GramCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_oneSELambdaMod_CONUS_C4 <- getModelStatement(coefficientTable = CONUS_c4_trimAnoms,
modelName <- "coefficientValue_1seLambda",
responseVar <- "c4 cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_oneSELambdaMod_CONUS_C4$scaledInputVars_ModelStatement)## [1] "c4 cover percentage~ exp(-2.152686603 + 0.423638243*tmean + 1.409573134*prcpTempCorr + 0.904982906*isothermality + -0.005612865*prcpTempCorr:isothermality) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_oneSELambdaMod_CONUS_C4$unscaledInputVars_scaledModelStatement)## [1] "c4 cover percentage~ exp(-2.152686603 + 0.423638243*((tmean - 10.128868063) / 4.820305195) + 1.409573134*((prcpTempCorr - -0.120168217) / 0.410373104) + 0.904982906*((isothermality - 38.131295504) / 5.017482043) + -0.005612865*((prcpTempCorr - -0.120168217) / 0.410373104):isothermality) - 2"Predict
# predict w/ best SE lambda model
bestLambda_CONUS_C4_predict <- makePredictions(predictionDF = climDatPred,
modelObject = oneSELambdaMod_CONUS_C4)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C4_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = oneSELambdaMod_CONUS_C4)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C4_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = oneSELambdaMod_CONUS_C4)forb as proportion of total herbaceous, CONUS-wide - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
oneSELambdaMod_CONUS_forb <- readRDS("./models/betaLASSO/ForbCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_oneSELambdaMod_CONUS_forb <- getModelStatement(coefficientTable = CONUS_forb_trimAnoms,
modelName <- "coefficientValue_1seLambda",
responseVar <- "forb cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_oneSELambdaMod_CONUS_forb$scaledInputVars_ModelStatement)## [1] "forb cover percentage~ exp(-0.612615574 + 0.094292804*tmean + 0.631412160*prcp + -0.091101568*prcp_seasonality + -0.061591477*prcpTempCorr + -0.080733465*isothermality + 0.064932495*sand + 0.119108258*coarse + 0.012753143*AWHC + -0.059072555*prcp_seasonality_anom + 0.049222076*annWetDegDays_anom + 0.102663854*I(tmean^2) + 0.030196097*I(prcp_seasonality^2) + 0.010753776*I(isothermality^2) + 0.014883618*I(prcp_seasonality_anom^2) + 0.003575447*I(isothermality_anom^2) + 0.012683956*I(annWetDegDays_anom^2) + 0.000833123*I(sand^2) + -0.022685978*I(AWHC^2) + -0.052659007*prcpTempCorr:annWetDegDays + -0.238636236*tmean:annWetDegDays + -0.011920028*isothermality:annWetDegDays_anom + 0.025095543*isothermality:isothermality_anom + 0.018357908*prcp:isothermality + -0.069730992*prcpTempCorr:isothermality + 0.067141822*tmean:isothermality + 0.049533582*prcp:isothermality_anom + 0.030224163*prcp_seasonality_anom:isothermality_anom + 0.026984979*prcpTempCorr:isothermality_anom + 0.030121480*prcpTempCorr_anom:isothermality_anom + -0.042328089*tmean:isothermality_anom + -0.084548629*prcp:prcp_seasonality + 0.000501854*prcp_seasonality:prcpTempCorr_anom + -0.033668119*prcpTempCorr:prcp_seasonality_anom + 0.018981182*prcp_seasonality_anom:prcpTempCorr_anom + -0.016596864*tmean:prcp_seasonality_anom + 0.070687900*tmean:prcpTempCorr + 0.035475842*tmean:prcpTempCorr_anom + -0.145717807*sand:AWHC + -0.090887100*sand:coarse + 0.035666966*annWetDegDays_anom:prcpTempCorr_anom) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_oneSELambdaMod_CONUS_forb$unscaledInputVars_scaledModelStatement)## [1] "forb cover percentage~ exp(-0.612615574 + 0.094292804*((tmean - 10.128868063) / 4.820305195) + 0.631412160*((prcp - 613.807482136) / 502.16616755) + -0.091101568*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.061591477*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.080733465*((isothermality - 38.131295504) / 5.017482043) + 0.064932495*((sand - 47.700975096) / 16.735018944) + 0.119108258*((coarse - 12.778661958) / 11.312037701) + 0.012753143*((AWHC - 13.675056673) / 5.155918864) + -0.059072555*((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.049222076*((annWetDegDays_anom - 0.01940939) / 0.210157273) + 0.102663854*I(((tmean - 10.128868063) / 4.820305195)^2) + 0.030196097*I(((prcp_seasonality - 0.922874288) / 0.245115393)^2) + 0.010753776*I(((isothermality - 38.131295504) / 5.017482043)^2) + 0.014883618*I(((prcp_seasonality_anom - -0.024139995) / 0.116006989) ^2) + 0.003575447*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + 0.012683956*I(((annWetDegDays_anom - 0.01940939) / 0.210157273)^2) + 0.000833123*I(((sand - 47.700975096) / 16.735018944)^2) + -0.022685978*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.052659007*((prcpTempCorr - -0.120168217) / 0.410373104):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.238636236*((tmean - 10.128868063) / 4.820305195):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.011920028*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays_anom - 0.01940939) / 0.210157273) + 0.025095543*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496) + 0.018357908*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + -0.069730992*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + 0.067141822*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) + 0.049533582*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496) + 0.030224163*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((isothermality_anom - 0.504344509) / 1.294064496) + 0.026984979*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496) + 0.030121480*((prcpTempCorr_anom - 0.00832419) / 0.119050826):((isothermality_anom - 0.504344509) / 1.294064496) + -0.042328089*((tmean - 10.128868063) / 4.820305195):((isothermality_anom - 0.504344509) / 1.294064496) + -0.084548629*((prcp - 613.807482136) / 502.16616755):((prcp_seasonality - 0.922874288) / 0.245115393) + 0.000501854*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.033668119*((prcpTempCorr - -0.120168217) / 0.410373104):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.018981182*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.016596864*((tmean - 10.128868063) / 4.820305195):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.070687900*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.035475842*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.145717807*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + -0.090887100*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701) + 0.035666966*((annWetDegDays_anom - 0.01940939) / 0.210157273):((prcpTempCorr_anom - 0.00832419) / 0.119050826)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_CONUS_forb_predict <- makePredictions(predictionDF = climDatPred,
modelObject = oneSELambdaMod_CONUS_forb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_forb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = oneSELambdaMod_CONUS_forb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_forb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = oneSELambdaMod_CONUS_forb)needle-leaved tree as proportion of total tree, forest - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_forest_needleLeavedTree <- readRDS("./models/betaLASSO/ConifTreeCover_prop_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambdaMod_forest_needleLeavedTree <- getModelStatement(coefficientTable = forest_needleLeavedTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "needleLeavedTree cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambdaMod_forest_needleLeavedTree$scaledInputVars_ModelStatement)## [1] "needleLeavedTree cover percentage~ exp( 1.37111313 + -0.17935873*tmean + -0.49763469*prcp_dry + 0.40113711*sand + 0.37360661*carbon + -0.34582196*AWHC + 0.05286743*I(isothermality^2) + 0.37641491*prcpTempCorr:isothermality + -0.10304070*isothermality:prcpTempCorr_anom + 0.08187013*prcp:isothermality_anom + -0.11696478*prcp_dry:prcpTempCorr + 0.09370766*tmean:prcp_dry + 0.42568784*sand:coarse) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambdaMod_forest_needleLeavedTree$unscaledInputVars_scaledModelStatement)## [1] "needleLeavedTree cover percentage~ exp( 1.37111313 + -0.17935873*((tmean - 10.128868063) / 4.820305195) + -0.49763469*((prcp_dry - 5.007463659) / 8.212611388) + 0.40113711*((sand - 47.700975096) / 16.735018944) + 0.37360661*((carbon - 3.67729377) / 6.403824534) + -0.34582196*((AWHC - 13.675056673) / 5.155918864) + 0.05286743*I(((isothermality - 38.131295504) / 5.017482043)^2) + 0.37641491*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + -0.10304070*((isothermality - 38.131295504) / 5.017482043):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + 0.08187013*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496) + -0.11696478*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.09370766*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) + 0.42568784*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_forest_needleLeavedTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_forest_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_needleLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_forest_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_needleLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_forest_needleLeavedTree)needle-leaved tree as proportion of total tree, grass/shrub - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_grassShrub_needleLeavedTree <- readRDS("./models/betaLASSO/ConifTreeCover_prop_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree <- getModelStatement(coefficientTable = grassShrub_needleLeavedTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "needleLeavedTree cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree$scaledInputVars_ModelStatement)## [1] "needleLeavedTree cover percentage~ exp( 2.445095554 + -0.456318178*tmean + -1.549364543*prcp + -0.418685632*AWHC + -0.991719622*I(tmean^2) + -0.282668471*I(prcpTempCorr^2) + -0.007165025*I(isothermality^2) + 0.018801377*I(prcpTempCorr_anom^2) + -0.074950890*I(AWHC^2) + -0.720484757*tmean:isothermality + -0.500578960*tmean:prcpTempCorr + 0.234281518*AWHC:coarse) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree$unscaledInputVars_scaledModelStatement)## [1] "needleLeavedTree cover percentage~ exp( 2.445095554 + -0.456318178*((tmean - 10.128868063) / 4.820305195) + -1.549364543*((prcp - 613.807482136) / 502.16616755) + -0.418685632*((AWHC - 13.675056673) / 5.155918864) + -0.991719622*I(((tmean - 10.128868063) / 4.820305195)^2) + -0.282668471*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.007165025*I(((isothermality - 38.131295504) / 5.017482043)^2) + 0.018801377*I(((prcpTempCorr_anom - 0.00832419) / 0.119050826)^2) + -0.074950890*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.720484757*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) + -0.500578960*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.234281518*((AWHC - 13.675056673) / 5.155918864):((coarse - 12.778661958) / 11.312037701)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_grassShrub_needleLeavedTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_grassShrub_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_needleLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_grassShrub_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_needleLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_grassShrub_needleLeavedTree)broad-leaved tree as proportion of total tree, forest - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_forest_broadLeavedTree <- readRDS("./models/betaLASSO/AngioTreeCover_prop_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambdaMod_forest_broadLeavedTree <- getModelStatement(coefficientTable = forest_broadLeavedTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "broadLeavedTree cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambdaMod_forest_broadLeavedTree$scaledInputVars_ModelStatement)## [1] "broadLeavedTree cover percentage~ exp(-1.04095920 + 0.17366458*tmean + 0.46029844*prcp_dry + 0.15397199*prcpTempCorr + -0.40824352*sand + -0.39133812*carbon + 0.33586513*AWHC + -0.11018400*prcpTempCorr_anom + -0.06898374*I(isothermality^2) + -0.36392846*prcpTempCorr:isothermality + -0.09700734*prcp:isothermality_anom + 0.08258717*prcp_dry:prcpTempCorr + -0.12349491*tmean:prcp_dry + -0.42561043*sand:coarse) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambdaMod_forest_broadLeavedTree$unscaledInputVars_scaledModelStatement)## [1] "broadLeavedTree cover percentage~ exp(-1.04095920 + 0.17366458*((tmean - 10.128868063) / 4.820305195) + 0.46029844*((prcp_dry - 5.007463659) / 8.212611388) + 0.15397199*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.40824352*((sand - 47.700975096) / 16.735018944) + -0.39133812*((carbon - 3.67729377) / 6.403824534) + 0.33586513*((AWHC - 13.675056673) / 5.155918864) + -0.11018400*((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.06898374*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.36392846*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + -0.09700734*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496) + 0.08258717*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) + -0.12349491*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) + -0.42561043*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_forest_broadLeavedTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_forest_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_broadLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_forest_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_broadLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_forest_broadLeavedTree)broad-leaved tree as proportion of total tree, grassShrub - best lambda model
Read in the objects
# read in model objects (is the trim anomaly version)
bestLambdaMod_grassShrub_broadLeavedTree <- readRDS("./models/betaLASSO/AngioTreeCover_prop_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")
ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree <- getModelStatement(coefficientTable = grassShrub_broadLeavedTree_trimAnoms,
modelName <- "coefficientValue_bestLambda",
responseVar <- "broadLeavedTree cover percentage")This is the best Lambda model equation if the inputs are scaled:
(ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree$scaledInputVars_ModelStatement)## [1] "broadLeavedTree cover percentage~ exp(-1.807187155 + 0.652460140*tmean + 0.979557507*prcp + -0.176042723*prcpTempCorr + 0.081019085*sand + 0.391363994*coarse + 0.562437594*AWHC + -0.257519658*prcp_seasonality_anom + 0.738816644*I(tmean^2) + 0.435985654*I(prcpTempCorr^2) + 0.054837095*I(isothermality_anom^2) + -0.007055441*I(coarse^2) + 0.103295026*I(AWHC^2) + 0.031564850*isothermality:isothermality_anom + -0.223847233*prcpTempCorr:isothermality + 0.629262630*tmean:isothermality + 0.098746055*prcp_seasonality_anom:isothermality_anom + 0.152657720*prcpTempCorr:isothermality_anom + 0.170722905*prcp_seasonality:prcpTempCorr_anom + 0.115774462*tmean:prcp_seasonality_anom + 0.470988259*tmean:prcpTempCorr + 0.053978203*tmean:prcpTempCorr_anom + -0.191502134*coarse:AWHC + -0.352779396*sand:AWHC + -0.379793154*sand:coarse) - 2"This is the best Lambda model equation if the inputs are not scaled:
(ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree$unscaledInputVars_scaledModelStatement)## [1] "broadLeavedTree cover percentage~ exp(-1.807187155 + 0.652460140*((tmean - 10.128868063) / 4.820305195) + 0.979557507*((prcp - 613.807482136) / 502.16616755) + -0.176042723*((prcpTempCorr - -0.120168217) / 0.410373104) + 0.081019085*((sand - 47.700975096) / 16.735018944) + 0.391363994*((coarse - 12.778661958) / 11.312037701) + 0.562437594*((AWHC - 13.675056673) / 5.155918864) + -0.257519658*((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.738816644*I(((tmean - 10.128868063) / 4.820305195)^2) + 0.435985654*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + 0.054837095*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + -0.007055441*I(((coarse - 12.778661958) / 11.312037701)^2) + 0.103295026*I(((AWHC - 13.675056673) / 5.155918864)^2) + 0.031564850*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496) + -0.223847233*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + 0.629262630*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) + 0.098746055*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((isothermality_anom - 0.504344509) / 1.294064496) + 0.152657720*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496) + 0.170722905*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + 0.115774462*((tmean - 10.128868063) / 4.820305195):((prcp_seasonality_anom - -0.024139995) / 0.116006989) + 0.470988259*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + 0.053978203*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.191502134*((coarse - 12.778661958) / 11.312037701):((AWHC - 13.675056673) / 5.155918864) + -0.352779396*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + -0.379793154*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"Predict
# predict w/ best SE lambda model
bestLambda_grassShrub_broadLeavedTree_predict <- makePredictions(predictionDF = climDatPred,
modelObject = bestLambdaMod_grassShrub_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_broadLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1,
modelObject = bestLambdaMod_grassShrub_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_broadLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2,
modelObject = bestLambdaMod_grassShrub_broadLeavedTree)Combine the level 2 cover variables (combine and scale to sum to 100 - for both total herbaceous and total tree cover)
rm(climDatPred)
gc() ## used (Mb) gc trigger (Mb) limit (Mb) max used (Mb)
## Ncells 3540080 189.1 7541957 402.8 NA 7541957 402.8
## Vcells 773037430 5897.9 1245276334 9500.8 65536 2511826459 19163.8# for contemporary data
names(bestLambda_CONUS_C3_predict)[57] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predict)[57] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predict)[57] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predict)[57] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predict)[57] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predict)[57] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predict)[57] <- "needleLeavedTree_forest_percentage_pred"
level2_cover_preds_contemp <- bestLambda_CONUS_C3_predict %>%
cbind(bestLambda_CONUS_C4_predict %>% select(C4_percentage_pred)) %>%
cbind(bestLambda_CONUS_forb_predict %>% select(forb_percentage_pred)) %>%
cbind(bestLambda_grassShrub_broadLeavedTree_predict %>% select(broadLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_broadLeavedTree_predict %>% select(broadLeavedTree_forest_percentage_pred)) %>%
cbind(bestLambda_grassShrub_needleLeavedTree_predict %>% select(needleLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_needleLeavedTree_predict %>% select(needleLeavedTree_forest_percentage_pred))
level2_cover_preds_contemp <- level2_cover_preds_contemp %>%
mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred + C4_percentage_pred + forb_percentage_pred,
"sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,
"sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>%
mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))
# for future model 1
names(bestLambda_CONUS_C3_predictFuture_1)[55] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predictFuture_1)[55] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predictFuture_1)[55] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predictFuture_1)[55] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predictFuture_1)[55] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predictFuture_1)[55] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predictFuture_1)[55] <- "needleLeavedTree_forest_percentage_pred"
level2_cover_preds_future1 <- bestLambda_CONUS_C3_predictFuture_1 %>%
cbind(bestLambda_CONUS_C4_predictFuture_1 %>% select(C4_percentage_pred)) %>%
cbind(bestLambda_CONUS_forb_predictFuture_1 %>% select(forb_percentage_pred)) %>%
cbind(bestLambda_grassShrub_broadLeavedTree_predictFuture_1%>% select(broadLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_broadLeavedTree_predictFuture_1%>% select(broadLeavedTree_forest_percentage_pred)) %>%
cbind(bestLambda_grassShrub_needleLeavedTree_predictFuture_1%>% select(needleLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_needleLeavedTree_predictFuture_1%>% select(needleLeavedTree_forest_percentage_pred))
level2_cover_preds_future1 <- level2_cover_preds_future1 %>%
mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred + C4_percentage_pred + forb_percentage_pred,
"sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,
"sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>%
mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))
# for model 2
names(bestLambda_CONUS_C3_predictFuture_2)[55] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predictFuture_2)[55] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predictFuture_2)[55] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predictFuture_2)[55] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predictFuture_2)[55] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predictFuture_2)[55] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predictFuture_2)[55] <- "needleLeavedTree_forest_percentage_pred"
level2_cover_preds_future2 <- bestLambda_CONUS_C3_predictFuture_2 %>%
cbind(bestLambda_CONUS_C4_predictFuture_2 %>% select(C4_percentage_pred)) %>%
cbind(bestLambda_CONUS_forb_predictFuture_2 %>% select(forb_percentage_pred)) %>%
cbind(bestLambda_grassShrub_broadLeavedTree_predictFuture_2%>% select(broadLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_broadLeavedTree_predictFuture_2%>% select(broadLeavedTree_forest_percentage_pred)) %>%
cbind(bestLambda_grassShrub_needleLeavedTree_predictFuture_2%>% select(needleLeavedTree_grassShrub_percentage_pred)) %>%
cbind(bestLambda_forest_needleLeavedTree_predictFuture_2%>% select(needleLeavedTree_forest_percentage_pred))
level2_cover_preds_future2 <- level2_cover_preds_future2 %>%
mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred + C4_percentage_pred + forb_percentage_pred,
"sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,
"sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>%
mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))visualize the scaled level 2 predictions
i.e. the following predictions are the proportion of the relevant level 1 group (total herbaceous or total tree) that is composed of each level 2 functional group, after those groups have been ‘scaled’ to sum to 1 (e.g. proportion of total herbaceous that is C3, C4, or forb sums to 1)
C3 cover
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C3_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C3_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C3_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_C3_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C3GramCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_C3_proportion_2 <- plotObservations_C3_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the
CONUS ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the
CONUS ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the
CONUS ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_C3 <- ggplot() +
geom_spatraster(data = plotObservations_C3_proportion_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is C3GramCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(C3GramCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_C3_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
CONUS-wide model of C3GramCover_prop"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of C3GramCover_prop; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of C3GramCover_prop;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_C3, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of C3GramCover_prop with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
C4 cover
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C4_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C4_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C4_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_C4_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "C4GramCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_C4_proportion_2 <- plotObservations_C4_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the
CONUS ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the
CONUS ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the
CONUS ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_C4 <- ggplot() +
geom_spatraster(data = plotObservations_C4_proportion_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is C4GramCover")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(C4GramCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_C4_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
CONUS-wide model of C4GramCover_prop"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of C4GramCover_prop; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of C4GramCover_prop;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_C4, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of C4GramCover_prop with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
forb cover
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "forb_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "forb_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "forb_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_forb_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "ForbCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_forb_proportion_2 <- plotObservations_forb_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the
CONUS ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the
CONUS ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the
CONUS ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_forb <- ggplot() +
geom_spatraster(data = plotObservations_forb_proportion_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is Forbs")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(ForbCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_forb_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
CONUS-wide model of forb cover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of forb cover; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
CONUS-wide model of forb cover;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_forb, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of forb proportion with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
broad-leaved tree cover – forest
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_broadLeaved_forest_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "AngioTreeCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_broadLeaved_forest_proportion_2 <- plotObservations_broadLeaved_forest_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
forest ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
forest ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
forest ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_forest_broadLeavedTree <- ggplot() +
geom_spatraster(data = plotObservations_broadLeaved_forest_proportion_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is Broad-leaved tree")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(AngioTreeCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_broadLeaved_forest_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
forest model of broad-leaved tree cover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
forest model of broad-leaved tree covver; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
forest model of broad-leaved tree covver;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_forest_broadLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of broadLeavedTree proportion in forests with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
needle-leaved tree cover – forest
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_forest_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_needleLeaved_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "ConifTreeCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_needleLeaved_proportion_2 <- plotObservations_needleLeaved_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
forest ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
forest ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
forest ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_needleLeavedTree <- ggplot() +
geom_spatraster(data = plotObservations_needleLeaved_proportion) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is needle-leaved")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(ConifTreeCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_needleLeaved_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
forest model of needle-leaved tree cover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
forest model of needle-leaved tree covver; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
forest model of needle-leaved tree cover;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_needleLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of needleLeavedTree proportion with Forest Model using Contemporary and Forecasted Climate Data", fig.lab.size = 20)
broad-leaved tree cover – grass/shrub
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "broadLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_broadLeaved_grassShrub_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "AngioTreeCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_broadLeaved_grassShrub_proportion_2 <- plotObservations_broadLeaved_grassShrub_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
grass/shrub ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
grass/shrub ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the
grass/shrub ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_grassShrub_broadLeavedTree <- ggplot() +
geom_spatraster(data = plotObservations_broadLeaved_grassShrub_proportion_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is Broad-leaved tree")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(AngioTreeCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_broadLeaved_grassShrub_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
grass/shrub model of broad-leaved tree cover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
grass/shrub model of broad-leaved tree covver; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
grass/shrub model of broad-leaved tree covver;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_grassShrub_broadLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of broadLeavedTree proportion in grass/shrub with Contemporary and Forecasted Climate Data", fig.lab.size = 20)
needle-leaved tree cover – grass/shrub
# predict w/ best model
plotObs <- level2_cover_preds_contemp %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly
plotObs_2 <- plotObs %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("x", "y")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "needleLeavedTree_grassShrub_percentage_scaled",
fun = mean, na.rm = TRUE)
plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# get plot of observations
plotObservations_needleLeaved_proportion <- modDat_1_s %>%
#drop_na(paste(response)) %>%
#slice_sample(n = 5e4) %>%
terra::vect(geom = c("Long", "Lat")) %>%
terra::set.crs(crs(test_rast)) %>%
terra::rasterize(y = test_rast,
field = "ConifTreeCover_prop",
fun = mean, na.rm = TRUE)
plotObservations_needleLeaved_proportion_2 <- plotObservations_needleLeaved_proportion %>%
crop(ext(min(tempExt[,1]), max(tempExt[,1]),
min(tempExt[,2]), max(tempExt[,2]))
)
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
grass/shrub ecoregion
using contemporary climate data"),
subtitle = "bestLambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
grass/shrub ecoregion
using modeled climate data from BNU-ESM model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the
grass/shrub ecoregion
using modeled climate data from IPSL-CM5A-MR model"),
subtitle = "best Lambda model") +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
map_obs_CONUS_needleLeavedTree <- ggplot() +
geom_spatraster(data = plotObservations_needleLeaved_proportion) +
geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is needle-leaved")) +
scale_fill_gradient2(low = "brown",
mid = "wheat" ,
high = "darkgreen" ,
midpoint = 0, limits = c(0,1), na.value = "lightgrey") +
xlim(st_bbox(plotObs_2)[c(1,3)]) +
ylim(st_bbox(plotObs_2)[c(2,4)])
hist <- ggplot(level2_cover_preds_contemp) +
geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture1 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_bestlambdaFuture2 <- ggplot(level2_cover_preds_future1) +
geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
hist_obs <- ggplot(modDat_1_s) +
geom_density(aes(ConifTreeCover_prop), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ggtitle("Pink = predictions within
the focal ecoregion") +
ylab("frequency")
## calculate residuals for contemporary prediction
# (observed - predicted)
resids <- plotObservations_needleLeaved_proportion_2 - plotObs_2
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Resids. (obs. - pred.) from the
grass/shrub model of needle-leaved tree cover"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model with contemporary climate data") +
scale_fill_gradient2(low = "red",
mid = "white" ,
high = "blue" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(resids)[c(1,3)]) +
ylim(st_bbox(resids)[c(2,4)])
hist_trimAnoms_resids <- ggplot(resids) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency") +
geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <- plotObs_bestLambdaFuture1_2 - plotObs_2
map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
grass/shrub model of needle-leaved tree covver; (models with
predictions with modeled climate data from model BNU-ESM
model - models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model1)[c(1,3)]) +
ylim(st_bbox(predDeltas_model1)[c(2,4)])
hist_deltas_model1 <- ggplot(predDeltas_model1) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <- plotObs_bestLambdaFuture2_2 - plotObs_2
map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) +
geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA ) +
geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
labs(title = paste0("Future Climate Model Deltas for
grass/shrub model of needle-leaved tree cover;
(models with predictions with modeled
climate data from model IPSL-CM5A-MR
model- models with predictions from
contemporary climate data)"),
subtitle = "using predictions from the Trim Anomalies
bestLambda model") +
scale_fill_gradient2(low = "orange",
mid = "white" ,
high = "purple" ,
midpoint = 0, na.value = "grey20",
limits = c(-1,1)
) +
xlim(st_bbox(predDeltas_model2)[c(1,3)]) +
ylim(st_bbox(predDeltas_model2)[c(2,4)])
hist_deltas_model2 <- ggplot(predDeltas_model2) +
geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") +
xlab("Predicted Value") +
ylab("frequency")
## conglomerate figure
ggarrange(map_obs_CONUS_needleLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow = 2)
# plot model forecasts with model that does not exclude anomalies
ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2,
map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
heights = c(3,1), ncol = 3, nrow = 4) %>%
annotate_figure(fig.lab = "Model Predictions of needleLeavedTree proportion with grass/shrub Model using Contemporary and Forecasted Climate Data", fig.lab.size = 20)